Seems like a working parser

3 files changed, 140 insertions, 126 deletions

diff --git a/examples/test1.hs b/examples/test1.hs
index 7bd2ee3..2a3a834 100644
--- a/examples/test1.hs
+++ b/examples/test1.hs
@@ -12,7 +12,7 @@ g y ding = ding f (y - 2) + 7
 reverse :: [a] -> [a]
 reverse l =
   let go [] acc = acc
-      go (x:xs) acc = go xs (x:acc)
+      go (x:xs) acc  go xs (x:acc) 7 ->
   in go l []
 
 kaas = 42
diff --git a/hs-visinter.cabal b/hs-visinter.cabal
index e81ba90..0639cde 100644
--- a/hs-visinter.cabal
+++ b/hs-visinter.cabal
@@ -13,6 +13,7 @@ executable hs-visinter
     AST
     Control.FAlternative
     Parser
+    Pretty
   build-depends:
     base >= 4.16 && < 4.20,
     containers >= 0.6.3.1 && < 0.8,
diff --git a/src/Parser.hs b/src/Parser.hs
index 9b3bfdb..1746eca 100644
--- a/src/Parser.hs
+++ b/src/Parser.hs
@@ -29,10 +29,11 @@ import Control.Monad.Reader
 import Control.Monad.State.Lazy
 import Data.Char
 import Data.Either (partitionEithers)
+import Data.Foldable
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.These
 
-import Debug.Trace
+-- import Debug.Trace
 
 import AST
 import Control.FAlternative
@@ -201,7 +202,7 @@ pTopDef = do
   noFail isAtBlockLeft >>= \case
     True -> map Left <$> pDataDef0 <|>> map Right <$> pFunDef0
     False -> do
-      noFail $ raise Error "Skipping unparseable content"
+      raise Error "Skipping unparseable content"
       noFail $ readWhileInline (const True)
       pTopDef
 
@@ -250,10 +251,11 @@ pFunDef0 =
             Just (clause1 : clauses1) -> do
               clauses <- concat <$> famany (pFunEq (Continue name))
               return [FunDef name (Just typ) (clause1 :| clauses1 ++ clauses)]
-    ,do clause1@(FunEq name _ _) : clauses1 <- pFunEq FirstLine
-        noFail $ do
-          clauses <- concat <$> famany (pFunEq (Continue name))
-          return [FunDef name Nothing (clause1 :| clauses1 ++ clauses)]]
+    ,do pFunEq FirstLine >>= \case
+          clause1@(FunEq name _ _) : clauses1 -> noFail $ do
+            clauses <- concat <$> famany (pFunEq (Continue name))
+            return [FunDef name Nothing (clause1 :| clauses1 ++ clauses)]
+          [] -> faempty]
 
 -- | Given the name from the type signature or a previous clause, if any.
 pFunEq :: FunEqContext -> FParser [FunEq ()]
@@ -361,73 +363,84 @@ pPatExprAtom0 d =
                   ps <- pPattern 0 `sepBy1` (inlineWhite >> char ',')
                   return (PTup () (p : ps))]]
 
-{-
-pELet0 :: IParser (Expr ())
+pELet0 :: FParser (Expr ())
 pELet0 = do
   pKeyword "let"
-  inlineWhite
-  defs <- startLayoutBlock $ do
-    -- The first occurrence is also going to skip whitespace in front,
-    -- which is redundant -- but not harmful.
-    many $ do
-      skipWhiteComment
-      -- Note: now not necessarily in the indented block. Which is
-      -- precisely what we need here. If we see "in", let the 'many'
-      -- choice fail so that the defs loop ends. But let it fail outside
-      -- this asum so that it is the many that picks it up, not this
-      -- asum.
-      res <- asum [Nothing <$ pKeyword "in"  -- note: will be dropped due to the empty backtrack
-                  ,Just <$> pFunDef0]
-      case res of
-        Nothing -> empty
-        Just def -> return def
-  inlineWhite
-  asum [do pKeyword "in"
-           inlineWhite
-           body <- pExpr <|> (raise Error "Expected expression" >> return (ETup () []))
-           return (ELet () defs body)
-       ,do raise Error "Expected 'in' after 'let'"
-           return (ELet () defs (ETup () []))]
-
-pECase0 :: IParser (Expr ())
+  noFail $ do
+    inlineWhite
+    defss <- startLayoutBlock $ do
+      -- The first occurrence is also going to skip whitespace in front,
+      -- which is redundant -- but not harmful.
+      famany $ do
+        noFail skipWhiteComment
+        -- Note: now not necessarily in the indented block. Which is
+        -- precisely what we need here. If we see "in", let the 'many'
+        -- choice fail so that the defs loop ends. But let it fail outside
+        -- this asum so that it is the many that picks it up, not this
+        -- asum.
+        res <- faasum' [Nothing <$ pKeyword "in"  -- note: will be dropped due to the empty backtrack
+                       ,Just <$> pFunDef0]
+        case res of
+          Nothing -> faempty
+          Just defs -> return defs
+
+    let defs = concat defss
+    inlineWhite
+    facatch (do raise Error "Expected 'in' after 'let'"
+                return (ELet () defs (ETup () []))) $ do
+      pKeyword "in"
+      noFail $ do
+        inlineWhite
+        body <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
+        return (ELet () defs body)
+
+pECase0 :: FParser (Expr ())
 pECase0 = do
   pKeyword "case"
-  e <- pExpr
-  inlineWhite
-  pKeyword "of"
-  inlineWhite
-  startLayoutBlock $ do
-    -- The first clause is going to skip whitespace, but that's harmless
-    -- (though redundant).
-    let pClause = do
-          skipWhiteComment
-          whenM (not <$> isInsideBlock) (() <$ empty)
-          pat <- pPattern0 0
-          rhs <- pRHS "->"
-          return (pat, rhs)
-    clauses <- many pClause
-    return (ECase () e clauses)
-
-pEIf0 :: IParser (Expr ())
+  noFail $ do
+    e <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
+    inlineWhite
+    facatch (raise Error "Expected 'of' after 'case'" >> return (ECase () e [])) $ do
+      pKeyword "of"
+      noFail $ do
+        inlineWhite
+        startLayoutBlock $ do
+          -- The first clause is going to skip whitespace, but that's harmless
+          -- (though redundant).
+          let pClause = do
+                noFail $ skipWhiteComment
+                whenM (noFail $ not <$> isInsideBlock) (() <$ faempty)
+                pat <- pPattern0 0
+                noFail $ do
+                  rhs <- pRHS "->"
+                  return (pat, rhs)
+          clauses <- famany pClause
+          return (ECase () e clauses)
+
+pEIf0 :: FParser (Expr ())
 pEIf0 = do
   pKeyword "if"
-  e1 <- pExpr
-  inlineWhite
-  pKeyword "then"
-  e2 <- pExpr
-  inlineWhite
-  pKeyword "else"
-  e3 <- pExpr
-  return (EIf () e1 e2 e3)
+  noFail $ do
+    e1 <- pExpr <|>> (raise Error "Expected expression" >> return (ECon () (Name "True")))
+    inlineWhite
+    facatch (raise Error "Expected 'then' after 'if'" >> return (EIf () e1 (ETup () []) (ETup () []))) $ do
+      pKeyword "then"
+      noFail $ do
+        e2 <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
+        inlineWhite
+        facatch (raise Error "Expected else after 'if'" >> return (EIf () e1 (ETup () []) (ETup () []))) $ do
+          pKeyword "else"
+          noFail $ do
+            e3 <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () []))
+            return (EIf () e1 e2 e3)
 
-pExprOpExpr :: Int -> IParser (Expr ())
+pExprOpExpr :: Int -> FParser (Expr ())
 pExprOpExpr d = inlineWhite >> pExprOpExpr0 d
 
-pExprOpExpr0 :: Int -> IParser (Expr ())
+pExprOpExpr0 :: Int -> FParser (Expr ())
 pExprOpExpr0 d = do
   e0 <- pEApp0
   climbRight pExprOpExpr (snd <$> pInfixOp Don'tCare) (EOp ()) d e0 Nothing
--}
 
 climbRight
   :: (Int -> FParser e)  -- ^ Parse an expression at the given precedence level
@@ -450,44 +463,52 @@ climbRight pExpr' pOper makeOp d lhs mlhsop =
     rhs <- pExpr' oprhsd
     climbRight pExpr' pOper makeOp d (makeOp lhs op rhs) (Just paop)
 
-{-
-pEApp0 :: IParser (Expr ())
+pEApp0 :: FParser (Expr ())
 pEApp0 = do
   e1 <- pEAtom0
-  es <- many (inlineWhite >> pEAtom0)
+  es <- noFail $ famany (inlineWhite >> pEAtom0)
   case es of
     [] -> return e1
     _ -> return (EApp () e1 es)
 
-pEAtom0 :: IParser (Expr ())
-pEAtom0 = (ELit () <$> pLiteral0) <|> pEList0 <|> pEVar0 <|> pECon0 <|> pEParens0
+pEAtom0 :: FParser (Expr ())
+pEAtom0 = faasum'
+  [ELit () <$> pLiteral0
+  ,pEList0
+  ,pEVarOrCon0 
+  ,pEParens0]
 
-pLiteral0 :: IParser Literal
-pLiteral0 = asum
-  [do as <- some (satisfy isDigit)
+pLiteral0 :: FParser Literal
+pLiteral0 = faasum'
+  [do as <- toList <$> fasome (satisfy isDigit)
       let a = read as :: Integer
-      asum
-        [do char '.'
-            bs <- some (satisfy isDigit)
-            let b = read bs :: Integer
-            cs <- optional $ do
-                    char 'e'
-                    cs <- some (satisfy isDigit)
-                    return cs
-            let c = maybe 0 read cs :: Integer
-            return (LFloat ((fromIntegral a + fromIntegral b / 10 ^ length bs) * 10 ^ c))
-        ,return (LInt a)]
+      facatch (return (LInt a)) $ do
+        char '.'
+        bs <- toList <$> fasome (satisfy isDigit)
+        let b = read bs :: Integer
+        cs <- noFail $ faoptional $ do
+                char 'e'
+                cs <- toList <$> fasome (satisfy isDigit)
+                return cs
+        let c = maybe 0 read cs :: Integer
+        return (LFloat ((fromIntegral a + fromIntegral b / 10 ^ length bs) * 10 ^ c))
   ,do char '\''
-      c <- pStringChar
-      char '\''
-      return (LChar c)
+      facatch (raise Error "Unclosed character literal" >> return (LChar '?')) $ do
+        cs <- noFail $ famany pStringChar
+        char '\''
+        noFail $ do
+          c <- case cs of
+                 [c] -> return c
+                 _ -> raise Error "Character literal must contain one character" >> return '?'
+          return (LChar c)
   ,do char '"'
-      s <- many pStringChar
-      char '"'
-      return (LString s)]
+      noFail $ do
+        s <- famany pStringChar
+        char '"' <|>> raise Error "Unclosed string literal"
+        return (LString s)]
 
-pStringChar :: IParser Char
-pStringChar = asum
+pStringChar :: FParser Char
+pStringChar = faasum'
   [do char '\\'
       char 'x'
       let hexdig = do
@@ -496,7 +517,7 @@ pStringChar = asum
                     in 'a' <= c && c <= 'f' || '0' <= c && c <= '9'
             return $ if 'a' <= c then 10 + ord c - ord 'a'
                                  else ord c - ord '0'
-      digs <- some hexdig
+      digs <- toList <$> fasome hexdig
       return (chr (sum (zipWith (*) (reverse digs) (iterate (*16) 1))))
   ,do char '\\'
       satisfy (const True) >>= \case
@@ -512,28 +533,28 @@ pStringChar = asum
                 return '?'
   ,do satisfy (\c -> c `notElem` "\n\r\\\'")]
 
-pEList0 :: IParser (Expr ())
+pEList0 :: FParser (Expr ())
 pEList0 = do
   char '['  -- special syntax, no need for pKeySym
-  es <- sepBy pExpr (inlineWhite >> char ',')
-  inlineWhite
-  char ']'
-  return (EList () es)
-
-pEVar0 :: IParser (Expr ())
-pEVar0 = EVar () <$> pIdentifier0 InBlock Lowercase
+  noFail $ do
+    es <- sepBy pExpr (inlineWhite >> char ',')
+    inlineWhite
+    char ']' <|>> raise Error "Expected closing ']'"
+    return (EList () es)
 
-pECon0 :: IParser (Expr ())
-pECon0 = ECon () <$> pIdentifier0 InBlock Uppercase
+pEVarOrCon0 :: FParser (Expr ())
+pEVarOrCon0 =
+  pIdentifier0 InBlock Don'tCare () >>= \case
+    (Lowercase, name) -> return (EVar () name)
+    (Uppercase, name) -> return (ECon () name)
 
-pEParens0 :: IParser (Expr ())
+pEParens0 :: FParser (Expr ())
 pEParens0 = do
   char '('
   e <- pExpr
   inlineWhite
   char ')'
   return e
--}
 
 data Associativity = AssocLeft | AssocRight | AssocNone
   deriving (Show, Eq)
@@ -734,8 +755,8 @@ isNameContChar c = isNameHeadChar c || isDigit c || c == '\''
 pSymbol0 :: BlockPos -> Case care -> FParser (WithCaseOutput care Name)
 pSymbol0 bpos cs = do
   case bpos of
-    AtLeft -> noFail $ assertAtBlockLeft Fatal "Expected symbol, but found indented expression"
-    InBlock -> noFail $ assertInsideBlock Fatal "Expected symbol, but found end of indented expression"
+    AtLeft -> whenM (noFail $ not <$> isAtBlockLeft) (() <$ faempty)
+    InBlock -> whenM (noFail $ not <$> isInsideBlock) faempty
   (c1, adjoin) <-
     case cs of Lowercase -> (,id) <$> satisfy (\c -> isSymbolChar c && c /= ':')
                Uppercase -> (,id) <$> satisfy (== ':')
@@ -782,15 +803,15 @@ type family FatalCtx fatal a where
   FatalCtx 'False a = a ~ ()
   FatalCtx 'True a = ()
 
-raise_ :: Fatality fatal -> String -> IParser ()
+raise_ :: KnownFallible fail => Fatality fatal -> String -> Parser fail ()
 raise_ Error = raise Error
 raise_ Fatal = raise Fatal
 
-raise :: FatalCtx fatal a => Fatality fatal -> String -> IParser a
+raise :: (KnownFallible fail, FatalCtx fatal a) => Fatality fatal -> String -> Parser fail a
 raise fat msg = gets psCur >>= \pos -> raiseAt pos fat msg
 
 -- | Raise an error with the given fatality and description.
-raiseAt :: FatalCtx fatal a => Pos -> Fatality fatal -> String -> IParser a
+raiseAt :: (KnownFallible fail, FatalCtx fatal a) => Pos -> Fatality fatal -> String -> Parser fail a
 raiseAt pos fat msg = do
   Context { ctxFile = fp , ctxStack = stk } <- ask
   let err = ErrMsg fp stk pos msg
@@ -826,8 +847,8 @@ data BlockPos = AtLeft | InBlock
 readToken :: BlockPos -> (s -> Maybe Char -> Maybe (Either r s)) -> s -> FParser (r, String)
 readToken bpos f s0 = do
   case bpos of
-    AtLeft -> noFail $ assertAtBlockLeft Fatal "Expected token, but found indented expression"
-    InBlock -> noFail $ assertInsideBlock Fatal "Expected token, but found end of indented expression"
+    AtLeft -> whenM (noFail $ not <$> isAtBlockLeft) (() <$ faempty)
+    InBlock -> whenM (noFail $ not <$> isInsideBlock) faempty
   let loop :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> FParser (r, String)
       loop f' st = do
         ps <- get
@@ -873,7 +894,7 @@ blockComment = do
   string "{-"  -- no need for pKeySym here
   let loop = do
         faasum [string "-}"
-               ,eof >> noFail (raise Error "Unfinished {- -} comment at end of file")
+               ,eof >> raise Error "Unfinished {- -} comment at end of file"
                ,blockComment >> noFail loop
                ,consumeNewline >> noFail loop]
           (readWhileInline (`notElem` "{-"))  -- "-}" also starts with '-'
@@ -887,14 +908,6 @@ lineComment = do
   pKeySym "--"
   noFail $ readWhileInline (const True)
 
--- | Raises an error if we're not currently at the given column.
-assertAtBlockLeft :: Fatality fatal -> String -> IParser ()
-assertAtBlockLeft fat msg = whenM (not <$> isAtBlockLeft) $ raise_ fat msg
-
--- | Raises an error if psCol is not greater than psRefCol.
-assertInsideBlock :: Fatality fatal -> String -> IParser ()
-assertInsideBlock fat msg = whenM (not <$> isInsideBlock) $ raise_ fat msg
-
 -- | Raises an error if we're not currently at EOF.
 assertEOF :: Fatality fatal -> IParser ()
 assertEOF fat = gets psRest >>= \case
@@ -966,14 +979,14 @@ string s = do
                  , psRest = drop (length s) (psRest ps) })
     else faempty
 
-lookAhead :: FParser a -> FParser a
-lookAhead p = do
-  ps <- get
-  success <- (Just <$> p) <|>> pure Nothing
-  put ps  -- restore state, as if nothing happened
-  case success of
-    Nothing -> faempty
-    Just x -> return x
+-- lookAhead :: FParser a -> FParser a
+-- lookAhead p = do
+--   ps <- get
+--   success <- (Just <$> p) <|>> pure Nothing
+--   put ps  -- restore state, as if nothing happened
+--   case success of
+--     Nothing -> faempty
+--     Just x -> return x
 
 notFollowedBy :: FParser () -> FParser ()
 notFollowedBy p = do