aboutsummaryrefslogtreecommitdiff
path: root/src/Parser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser.hs')
-rw-r--r--src/Parser.hs263
1 files changed, 138 insertions, 125 deletions
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
generated by cgit v1.2.3-70-g09d2 (git 2.47.0) at 2024-11-01 06:22:00 +0100