diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Parser.hs | 263 |
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 |