Use explicit data structures to represent the AST on the browser side.

Previously we baked the AST into the HTML tree which made it hard to change and
add more information.

src/lib/AbstractSyntax.hs

@@ -195,7 +195,7 @@ withTrailingConstraints
   :: GroupW -> (GroupW -> SyntaxM (UAnnBinder VoidS VoidS))
   -> SyntaxM (Nest UAnnBinder VoidS VoidS)
 withTrailingConstraints g cont = case g of
-  WithSrcs _ _ (CBin Pipe lhs c) -> do
+  WithSrcs _ _ (CBin (WithSrc _ Pipe) lhs c) -> do
     Nest (UAnnBinder expl (WithSrcB sid b) ann cs) bs <- withTrailingConstraints lhs cont
     s <- case b of
       UBindSource s -> return s
@@ -253,7 +253,7 @@ explicitBindersOptAnn (WithSrcs _ _ bs) =
 
 -- Binder pattern with an optional type annotation
 patOptAnn :: GroupW -> SyntaxM (UPat VoidS VoidS, Maybe (UType VoidS))
-patOptAnn (WithSrcs _ _ (CBin Colon lhs typeAnn)) = (,) <$> pat lhs <*> (Just <$> expr typeAnn)
+patOptAnn (WithSrcs _ _ (CBin (WithSrc _ Colon) lhs typeAnn)) = (,) <$> pat lhs <*> (Just <$> expr typeAnn)
 patOptAnn (WithSrcs _ _ (CParens [g])) = patOptAnn g
 patOptAnn g = (,Nothing) <$> pat g
 
@@ -267,7 +267,7 @@ uBinder (WithSrcs sid _ b) = case b of
 tyOptPat :: GroupW -> SyntaxM (UAnnBinder VoidS VoidS)
 tyOptPat grpTop@(WithSrcs sid _ grp) = case grp of
   -- Named type
-  CBin Colon lhs typeAnn ->
+  CBin (WithSrc _ Colon) lhs typeAnn ->
     UAnnBinder Explicit <$> uBinder lhs <*> (UAnn <$> expr typeAnn) <*> pure []
   -- Binder in grouping parens.
   CParens [g] -> tyOptPat g
@@ -285,7 +285,7 @@ casePat = \case
 
 pat :: GroupW -> SyntaxM (UPat VoidS VoidS)
 pat (WithSrcs sid _ grp) = WithSrcB sid <$> case grp of
-  CBin DepComma lhs rhs -> do
+  CBin (WithSrc _ DepComma) lhs rhs -> do
     lhs' <- pat lhs
     rhs' <- pat rhs
     return $ UPatDepPair $ PairB lhs' rhs'
@@ -317,8 +317,8 @@ pat (WithSrcs sid _ grp) = WithSrcB sid <$> case grp of
 
 tyOptBinder :: Explicitness -> GroupW -> SyntaxM (UAnnBinder VoidS VoidS)
 tyOptBinder expl (WithSrcs sid sids grp) = case grp of
-  CBin Pipe  _ _     -> throw SyntaxErr "Unexpected constraint"
-  CBin Colon name ty -> do
+  CBin (WithSrc _ Pipe)  _ _     -> throw SyntaxErr "Unexpected constraint"
+  CBin (WithSrc _ Colon) name ty -> do
     b <- uBinder name
     ann <- UAnn <$> expr ty
     return $ UAnnBinder expl b ann []
@@ -328,7 +328,7 @@ tyOptBinder expl (WithSrcs sid sids grp) = case grp of
 
 binderOptTy :: Explicitness -> GroupW -> SyntaxM (UAnnBinder VoidS VoidS)
 binderOptTy expl = \case
-  WithSrcs _ _ (CBin Colon name ty) -> do
+  WithSrcs _ _ (CBin (WithSrc _ Colon) name ty) -> do
     b <- uBinder name
     ann <- UAnn <$> expr ty
     return $ UAnnBinder expl b ann []
@@ -337,7 +337,7 @@ binderOptTy expl = \case
     return $ UAnnBinder expl b UNoAnn []
 
 binderReqTy :: Explicitness -> GroupW -> SyntaxM (UAnnBinder VoidS VoidS)
-binderReqTy expl (WithSrcs _ _ (CBin Colon name ty)) = do
+binderReqTy expl (WithSrcs _ _ (CBin (WithSrc _ Colon) name ty)) = do
   b <- uBinder name
   ann <- UAnn <$> expr ty
   return $ UAnnBinder expl b ann []
@@ -348,7 +348,7 @@ argList gs = partitionEithers <$> mapM singleArg gs
 
 singleArg :: GroupW -> SyntaxM (Either (UExpr VoidS) (UNamedArg VoidS))
 singleArg = \case
-  WithSrcs _ _ (CBin CSEqual lhs rhs) -> Right <$>
+  WithSrcs _ _ (CBin (WithSrc _ CSEqual) lhs rhs) -> Right <$>
     ((,) <$> withoutSrc <$> identifier "named argument" lhs <*> expr rhs)
   g -> Left <$> expr g
 
@@ -450,7 +450,7 @@ expr (WithSrcs sid _ grp) = WithSrcE sid <$> case grp of
           args' <- mapM expr args
           return $ UTabApp f args'
         _ -> error "unexpected postfix group (should be ruled out at grouping stage)"
-  CBin op lhs rhs -> case op of
+  CBin (WithSrc opSid op) lhs rhs -> case op of
     Dollar             -> extendAppRight <$> expr lhs <*> expr rhs
     Pipe               -> extendAppLeft  <$> expr lhs <*> expr rhs
     Dot -> do
@@ -480,7 +480,7 @@ expr (WithSrcs sid _ grp) = WithSrcE sid <$> case grp of
       UTabPi . (UTabPiExpr lhs') <$> expr rhs
    where
     evalOp s = do
-      let f = WithSrcE (srcPos s) (fromSourceNameW s)
+      let f = WithSrcE opSid (fromSourceNameW (WithSrc opSid s))
       lhs' <- expr lhs
       rhs' <- expr rhs
       return $ explicitApp f [lhs', rhs']

src/lib/ConcreteSyntax.hs

@@ -71,8 +71,8 @@ mustParseSourceBlock s = mustParseit s sourceBlock
 
 -- === helpers for target ADT ===
 
-interpOperator :: WithSrc String -> Bin
-interpOperator (WithSrc sid s) = case s of
+interpOperator :: String -> Bin
+interpOperator = \case
   "&>"  -> DepAmpersand
   "."   -> Dot
   ",>"  -> DepComma
@@ -83,7 +83,7 @@ interpOperator (WithSrc sid s) = case s of
   "->>" -> ImplicitArrow
   "=>"  -> FatArrow
   "="   -> CSEqual
-  name  -> EvalBinOp $ WithSrc sid $ fromString $ "(" <> name <> ")"
+  name  -> EvalBinOp $ fromString $ "(" <> name <> ")"
 
 pattern Identifier :: SourceName -> GroupW
 pattern Identifier name <- (WithSrcs _ _ (CLeaf (CIdentifier name)))
@@ -477,7 +477,9 @@ cFor = do
                 <|> keyWord Rof_KW $> KRof_
 
 cDo :: Parser Group
-cDo = CDo <$> cBlock
+cDo = do
+  keyWord DoKW
+  CDo <$> cBlock
 
 cCase :: Parser Group
 cCase = do
@@ -584,9 +586,9 @@ leafGroup = leafGroup' >>= appendPostfixGroups
 
   appendFieldAccess :: GroupW -> Parser Group
   appendFieldAccess g = try do
-    void $ char '.'
+    sid <- dot
     field <- cFieldName
-    return $ CBin Dot g field
+    return $ CBin (WithSrc sid Dot) g field
 
 cFieldName :: Parser GroupW
 cFieldName = cIdentifier <|> (toCLeaf CNat <$> natLit)
@@ -675,13 +677,13 @@ addSrcIdToUnOp op = do
 
 backquoteOp :: Parser (GroupW -> GroupW -> GroupW)
 backquoteOp = binApp do
-  fname <- backquoteName
-  return $ EvalBinOp fname
+  WithSrc sid fname <- backquoteName
+  return $ WithSrc sid $ EvalBinOp fname
 
 anySymOp :: Expr.Operator Parser GroupW
 anySymOp = Expr.InfixL $ binApp do
-  s <- label "infix operator" (mayBreak anySym)
-  return $ interpOperator s
+  WithSrc sid s <- label "infix operator" (mayBreak anySym)
+  return $ WithSrc sid $ interpOperator s
 
 infixSym :: String -> Parser SrcId
 infixSym s = mayBreak $ symWithId $ T.pack s
@@ -698,7 +700,7 @@ symOpR s = (fromString s, Expr.InfixR $ symOp s)
 symOp :: String -> Parser (GroupW -> GroupW -> GroupW)
 symOp s = binApp do
   sid <- label "infix operator" (infixSym s)
-  return $ interpOperator (WithSrc sid s)
+  return $ WithSrc sid $ interpOperator s
 
 arrowOp :: Parser (GroupW -> GroupW -> GroupW)
 arrowOp = addSrcIdToBinOp do
@@ -714,7 +716,7 @@ prefixOp s = addSrcIdToUnOp do
   symId <- symWithId (fromString s)
   return $ CPrefix (WithSrc symId $ fromString s)
 
-binApp :: Parser Bin -> Parser (GroupW -> GroupW -> GroupW)
+binApp :: Parser BinW -> Parser (GroupW -> GroupW -> GroupW)
 binApp f = addSrcIdToBinOp $ CBin <$> f
 
 withClausePostfixOp :: Parser (GroupW -> GroupW)

src/lib/Lexing.hs

@@ -216,6 +216,10 @@ symChar = token (\c -> if HS.member c symChars then Just c else Nothing) mempty
 symChars :: HS.HashSet Char
 symChars = HS.fromList ".,!$^&*:-~+/=<>|?\\@#"
 
+-- XXX: unlike other lexemes, this doesn't consume trailing whitespace
+dot :: Parser SrcId
+dot = srcPos <$> lexeme' (return ()) Symbol (void $ char '.')
+
 -- === Util ===
 
 sc :: Parser ()
@@ -349,18 +353,22 @@ symbol :: Text -> Parser ()
 symbol s = void $ L.symbol sc s
 
 lexeme :: LexemeType -> Parser a -> Parser (WithSrc a)
-lexeme lexemeType p = do
+lexeme lexemeType p = lexeme' sc lexemeType p
+{-# INLINE lexeme #-}
+
+lexeme' :: Parser () -> LexemeType -> Parser a -> Parser (WithSrc a)
+lexeme' sc' lexemeType p = do
   start <- getOffset
   ans <- p
   end <- getOffset
   recordNonWhitespace
-  sc
+  sc'
   sid <- freshSrcId
   emitLexemeInfo $ mempty
     { lexemeList = toSnocList [sid]
     , lexemeInfo = M.singleton sid (lexemeType, (start, end)) }
   return $ WithSrc sid ans
-{-# INLINE lexeme #-}
+{-# INLINE lexeme' #-}
 
 atomicLexeme :: LexemeType -> Parser () -> Parser ()
 atomicLexeme lexemeType p = do

src/lib/Live/Eval.hs

@@ -28,6 +28,7 @@ import TopLevel
 import ConcreteSyntax
 import RenderHtml (ToMarkup, pprintHtml)
 import MonadUtil
+import Util (unsnoc)
 
 -- === Top-level interface ===
 
@@ -305,10 +306,24 @@ instance (ToJSON a, ToJSONKey k) => ToJSON (MapUpdate k a)
 instance ToJSON a => ToJSON (TailUpdate a)
 instance ToJSON a => ToJSON (MapEltUpdate a)
 instance ToJSON o => ToJSON (NodeEvalStatus o)
+instance ToJSON SrcId
+deriving instance ToJSONKey SrcId
+instance ToJSON ASTInfo
+instance ToJSON LexemeType
 instance (ToJSON i, ToJSON o) => ToJSON (NodeState i o)
 
+data SourceBlockJSONData = SourceBlockJSONData
+  { jdLine        :: Int
+  , jdBlockId     :: Int
+  , jdLexemeList  :: [SrcId]
+  , jdASTInfo     :: ASTInfo
+  , jdHTML        :: String }  deriving (Generic)
+
+instance ToJSON SourceBlockJSONData
+
 instance ToJSON SourceBlockWithId where
-  toJSON b@(SourceBlockWithId _ b') = toJSON (sbLine b', pprintHtml b)
+  toJSON b@(SourceBlockWithId blockId b') = toJSON $ SourceBlockJSONData
+   (sbLine b') blockId (unsnoc $ lexemeList $ sbLexemeInfo b') (sbASTInfo b') (pprintHtml b)
 instance ToJSON Result      where toJSON = toJSONViaHtml
 
 toJSONViaHtml :: ToMarkup a => a -> Value

src/lib/PPrint.hs

@@ -1084,7 +1084,7 @@ instance PrettyPrec Group where
   -- prettyPrec g = atPrec ArgPrec $ fromString $ show g
 
 instance Pretty Bin where
-  pretty (EvalBinOp name) = pretty (withoutSrc name)
+  pretty (EvalBinOp name) = pretty name
   pretty DepAmpersand = "&>"
   pretty Dot = "."
   pretty DepComma = ",>"

src/lib/RenderHtml.hs

@@ -76,7 +76,7 @@ instance ToMarkup Output where
 instance ToMarkup SourceBlockWithId where
   toMarkup (SourceBlockWithId blockId block) = case sbContents block of
     Misc (ProseBlock s) -> cdiv "prose-block" $ mdToHtml s
-    _ -> renderSpans blockId (sbLexemeInfo block) (sbASTInfo block) (sbText block)
+    _ -> renderSpans blockId (sbLexemeInfo block) (sbText block)
 
 mdToHtml :: T.Text -> Html
 mdToHtml s = preEscapedText $ commonmarkToHtml [] s
@@ -86,8 +86,8 @@ cdiv c inner = H.div inner ! class_ (stringValue c)
 
 type BlockId = Int
 
-renderSpans :: BlockId -> LexemeInfo -> ASTInfo -> T.Text -> Markup
-renderSpans blockId lexInfo astInfo sourceText = cdiv "code-block" do
+renderSpans :: BlockId -> LexemeInfo -> T.Text -> Markup
+renderSpans blockId lexInfo sourceText = cdiv "code-block" do
   runTextWalkerT sourceText do
     forM_ (lexemeList lexInfo) \sourceId -> do
       let (lexemeTy, (l, r)) = fromJust $ M.lookup sourceId (lexemeInfo lexInfo)

src/lib/SourceIdTraversal.hs

@@ -49,7 +49,7 @@ instance IsTree Group where
     CPrim _   xs -> mapM_ visit xs
     CParens   xs -> mapM_ visit xs
     CBrackets xs -> mapM_ visit xs
-    CBin _       l r -> visit l >> visit r
+    CBin       b l r -> visit b >> visit l >> visit r
     CJuxtapose _ l r -> visit l >> visit r
     CPrefix      l r -> visit l >> visit r
     CGivens (x,y) -> visit x >> visit y
@@ -111,3 +111,4 @@ instance (IsTree a, IsTree b, IsTree c) => IsTree (a, b, c) where
 instance IsTree AppExplicitness where visit _ = return ()
 instance IsTree SourceName      where visit _ = return ()
 instance IsTree LetAnn          where visit _ = return ()
+instance IsTree Bin             where visit _ = return ()

src/lib/Types/Source.hs

@@ -100,6 +100,7 @@ type GroupW      = WithSrcs Group
 type CTopDeclW   = WithSrcs CTopDecl
 type CSDeclW     = WithSrcs CSDecl
 type SourceNameW = WithSrc SourceName
+type BinW        = WithSrc Bin
 
 type BracketedGroup = WithSrcs [GroupW]
 -- optional arrow, effects, result type
@@ -161,7 +162,7 @@ data Group
   | CPrim PrimName [GroupW]
   | CParens   [GroupW]
   | CBrackets [GroupW]
-  | CBin Bin GroupW GroupW
+  | CBin BinW GroupW GroupW
   | CJuxtapose Bool GroupW GroupW -- Bool means "there's a space between the groups"
   | CPrefix SourceNameW GroupW -- covers unary - and unary + among others
   | CGivens GivenClause
@@ -187,7 +188,7 @@ data CLeaf
 type CaseAlt = (GroupW, CSBlock) -- scrutinee, lexeme Id, body
 
 data Bin
-  = EvalBinOp SourceNameW
+  = EvalBinOp SourceName
   | DepAmpersand
   | Dot
   | DepComma