From f72bf16e2edc8d654e661cd59f820409219e5f27 Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Sun, 25 Feb 2024 21:01:13 +0100 Subject: Add HSVIS module prefix --- src/Parser.hs | 1016 --------------------------------------------------------- 1 file changed, 1016 deletions(-) delete mode 100644 src/Parser.hs (limited to 'src/Parser.hs') diff --git a/src/Parser.hs b/src/Parser.hs deleted file mode 100644 index 76cc10e..0000000 --- a/src/Parser.hs +++ /dev/null @@ -1,1016 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE InstanceSigs #-} --- I don't want a warning for 'head' and 'tail' in this file. But I also don't --- want GHCs before 9.8 to complain that they don't know the x-partial warning. -{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-partial #-} -module Parser ( - parse, - printErrMsg, - -- * Re-exports - These(..), -) where - --- import Control.Applicative -import Control.Monad -import Control.Monad.Chronicle -import Control.Monad.Reader -import Control.Monad.State.Lazy -import Data.Char -import Data.Either (partitionEithers) -import Data.Foldable -import Data.List (intercalate) -import Data.List.NonEmpty (NonEmpty(..)) -import Data.These - --- import Debug.Trace - -import AST -import Control.FAlternative -import Pretty - - -data Pos = Pos - { posLine :: Int -- ^ zero-based - , posCol :: Int -- ^ zero-based - } - deriving (Show) - --- Positions are zero-based in both dimensions. --- See 'isInsideBlock' and 'isAtBlockLeft' for the two relevant "inside the --- block" conditions. -data PS = PS - { psBlk :: Pos -- ^ Start of current layout block - , psCur :: Pos -- ^ Current parsing position - , psRest :: String -- ^ Rest of the input - } - deriving (Show) - -data Context = Context - { ctxFile :: FilePath - , ctxLines :: [String] -- ^ The file contents, split up in lines - , ctxStack :: [String] -- ^ Stack of syntax scopes, for error reporting - } - deriving (Show) - -type family BacktrackPath fail r where - BacktrackPath 'Fallible r = r - BacktrackPath 'Infallible r = () - -newtype Parser fail a = Parser - { runParser - :: forall r. - Context - -> PS - -> (PS -> [ErrMsg] -> a -> r) -- ^ OK: some diagnostics, but parsing succeeded - -> ([ErrMsg] -> r) -- ^ Fatal: error that prevented parsing from proceeding - -> BacktrackPath fail r -- ^ Backtrack: alternative was exhausted without success - -> r } - -type IParser = Parser 'Infallible -type FParser = Parser 'Fallible - -instance Functor (Parser fail) where - fmap f (Parser g) = Parser (\ctx ps kok kfat kbt -> - g ctx ps (\ps' errs x -> kok ps' errs (f x)) kfat kbt) - -instance Applicative (Parser fail) where - pure x = Parser (\_ ps kok _ _ -> kok ps [] x) - (<*>) = ap - -instance Monad (Parser fail) where - Parser g >>= f = Parser $ \ctx ps kok kfat kbt -> - g ctx ps - (\ps1 errs x -> - x `seq` - runParser (f x) ctx ps1 - (\ps2 errs' y -> kok ps2 (errs <> errs') y) - (\errs' -> kfat (errs <> errs')) - kbt) - (\errs -> kfat errs) - kbt - -instance FAlternative Parser where - faempty = Parser (\_ _ _ _ kbt -> kbt) - Parser f <|>> Parser g = Parser $ \ctx ps kok kfat kbt -> - f ctx ps kok kfat (g ctx ps kok kfat kbt) - - noFail (Parser f) = Parser $ \ctx ps kok kfat _ -> f ctx ps kok kfat () - - toFallible :: forall fail a. KnownFallible fail => Parser fail a -> Parser 'Fallible a - toFallible (Parser f) = Parser $ \ctx ps kok kfat kbt -> - f ctx ps kok kfat (case knownFallible @fail of - SFallible -> kbt - SInfallible -> ()) - -instance MonadState PS (Parser fail) where - state f = Parser $ \_ ps kok _ _ -> - let (x, ps') = f ps - in kok ps' [] x - -instance MonadReader Context (Parser fail) where - reader f = Parser $ \ctx ps kok _ _ -> kok ps [] (f ctx) - local f (Parser g) = Parser (\ctx -> g (f ctx)) - -instance KnownFallible fail => MonadChronicle [ErrMsg] (Parser fail) where - dictate errs = Parser $ \_ ps kok _ _ -> kok ps errs () - confess errs = Parser $ \_ _ _ kfat _ -> kfat errs - memento (Parser f) = Parser $ \ctx ps kok _ kbt -> - f ctx ps - (\ps' errs x -> kok ps' errs (Right x)) - (\errs -> kok ps [] (Left errs)) - kbt - absolve def (toFallible -> Parser f) = Parser $ \ctx ps kok _ _ -> - f ctx ps - kok - (\_ -> kok ps [] def) - (kok ps [] def) - condemn (Parser f) = Parser $ \ctx ps kok kfat kbt -> - f ctx ps - (\ps' errs x -> case errs of - [] -> kok ps' [] x - _ -> kfat errs) - kfat - kbt - retcon g (Parser f) = Parser $ \ctx ps kok kfat kbt -> - f ctx ps - (\ps' errs x -> kok ps' (g errs) x) - (\errs -> kfat (g errs)) - kbt - chronicle th = case th of - This errs -> Parser (\_ _ _ kfat _ -> kfat errs) - That res -> Parser (\_ ps kok _ _ -> kok ps [] res) - These errs res -> Parser (\_ ps kok _ _ -> kok ps errs res) - --- Positions are zero-based in both dimensions -data ErrMsg = ErrMsg - { errFile :: FilePath - , errStk :: [String] - , errPos :: Pos - , errMsg :: String - , errSourceLine :: String } - deriving (Show) - -printErrMsg :: ErrMsg -> String -printErrMsg (ErrMsg fp stk (Pos y x) s srcline) = - let linenum = show (y + 1) - in intercalate "\n" $ - map (\descr -> "In " ++ descr ++ ":") (reverse stk) - ++ [fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s - ,map (\_ -> ' ') linenum ++ " |" - ,linenum ++ " | " ++ srcline - ,map (\_ -> ' ') linenum ++ " | " ++ replicate x ' ' ++ "^"] - -parse :: FilePath -> String -> These [ErrMsg] (Program ()) -parse fp source = - runParser pProgram (Context fp (lines source) []) (PS (Pos 0 0) (Pos 0 0) source) - (\_ errs res -> case errs of - [] -> That res - _ -> These errs res) - (\errs -> This errs) - () -- (This [ErrMsg fp [] (Pos 0 0) "Parse error, no grammar alternatives match your source"]) - -pProgram :: IParser (Program ()) -pProgram = do - defs <- pTopDefs - let (datadefs, fundefs) = partitionEithers defs - skipWhiteComment - assertEOF Error - return (Program datadefs fundefs) - -pTopDefs :: IParser [Either DataDef (FunDef ())] -pTopDefs = do - faoptional pTopDef >>= \case - Nothing -> do - skipWhiteComment - faoptional eof >>= \case - Nothing -> do - raise Error "Unparseable content" - readWhileInline (const True) - pTopDefs -- will skip the possible newline - Just () -> return [] - Just defs -> do - defs2 <- pTopDefs - return (defs ++ defs2) - -pTopDef :: FParser [Either DataDef (FunDef ())] -pTopDef = do - noFail skipWhiteComment - noFail isAtBlockLeft >>= \case - True -> map Left <$> pDataDef0 <|>> map Right <$> pFunDef0 - False -> do - raise Error "Skipping unparseable content" - noFail $ readWhileInline (const True) - pTopDef - -pDataDef0 :: FParser [DataDef] -pDataDef0 = do - pKeyword "data" - noFail $ do - inlineWhite - faoptional (pIdentifier0 InBlock Uppercase WCAssume) >>= \case - Nothing -> do - raise Error "Expected data declaration after 'data'" - return [] - Just name -> do - params <- famany (inlineWhite >> pIdentifier0 InBlock Lowercase WCBacktrack) - cons <- pDatacons "=" - return [DataDef name params cons] - where - pDatacons :: String -> IParser [(Name, [Type])] - pDatacons leader = do - inlineWhite - facatch (return []) $ do - pKeySym leader - inlineWhite - name <- pIdentifier0 InBlock Uppercase WCAssume - fields <- noFail $ famany pTypeAtom - rest <- noFail $ pDatacons "|" - return ((name, fields) : rest) - -data FunEqContext - = FirstLine - | TypeSig Name - | Continue Name - deriving (Show) - -pFunDef0 :: FParser [FunDef ()] -pFunDef0 = - faasum' - [do (name, typ) <- pStandaloneTypesig0 - noFail $ do - faoptional (pFunEq (TypeSig name)) >>= \case - Nothing -> do - raise Error $ "Expected function equation for " ++ pretty name ++ - " after type signature" - return [] - Just [] -> return [FunDef name (Just typ) (FunEq name [] (Plain (ETup () [])) :| [])] - Just (clause1 : clauses1) -> do - clauses <- concat <$> famany (pFunEq (Continue name)) - return [FunDef name (Just typ) (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 ()] -pFunEq fectx = do - noFail skipWhiteComment - faguardM isAtBlockLeft - - pushLocatedContext "function equation" $ do - name <- pIdentifier0 AtLeft Lowercase WCAssume - - -- We want to do various checks with what came before, and there are - -- multiple branches where we decide to continue parsing this equation. To - -- avoid code duplication or an early exit monad, we use a boolean here. - success <- case fectx of - FirstLine -> return True - TypeSig checkName - | name == checkName -> return True - | otherwise -> noFail $ do - raise Error $ "Name of function clause does not correspond with type signature: " ++ - pretty checkName - return False - Continue checkName -> do - faguard (name == checkName) -- this can still backtrack out of pFunEq - return True - - noFail $ if success - then do - pats <- famany (pPattern 11) - rhs <- pRHS "=" - return [FunEq name pats rhs] - else return [] - --- | Pass "=" for function definitions and "->" for case clauses. -pRHS :: String -> IParser (RHS ()) -pRHS sepsym = do - -- TODO: parse guards - inlineWhite - pKeySym sepsym <|>> raise Error ("Expected " ++ show sepsym) - expr <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () [])) - return (Plain expr) - -pPattern :: Int -> FParser (Pattern ()) -pPattern d = inlineWhite >> pPattern0 d - -pPattern0 :: Int -> FParser (Pattern ()) -pPattern0 d = do - p0 <- pPatExprAtom0 (max 10 d) - climbRight pPattern (pInfixOp Uppercase) (POp ()) d p0 Nothing - -pExpr :: FParser (Expr ()) -pExpr = do - inlineWhite - -- basics: lit, list, var, con, tup - -- expression atom: application of basics - -- expression parser: op - -- around: let, case, if - pushLocatedContext "expression" $ do - faasum' [pELet0 - ,pECase0 - ,pEIf0 - ,pExprOpExpr0 0] - -pPatExprAtom0 :: Int -> FParser (Pattern ()) -pPatExprAtom0 d = - faasum' [pPatWildcard0 - ,pPatVarOrAs0 - ,pPatCon0 - ,pPatList0 - ,pPatParens0] - where - pPatWildcard0 = pKeySym "_" >> return (PWildcard ()) - pPatVarOrAs0 = do - var <- pIdentifier0 InBlock Lowercase WCBacktrack - facatch (return (PVar () var)) $ do - inlineWhite - pKeySym "@" - noFail $ do - p <- pPattern 11 <|>> (raise Error "Expected pattern after '@'" >> return (PWildcard ())) - return (PAs () var p) - pPatCon0 = do - con <- pIdentifier0 InBlock Uppercase WCBacktrack - noFail $ if d > 10 - then return (PCon () con []) - else do args <- famany (pPattern 11) - return (PCon () con args) - pPatList0 = do - char '[' -- special syntax, no need for pKeySym - noFail $ do - ps <- pPattern 0 `sepBy` (inlineWhite >> char ',') - inlineWhite - char ']' <|>> raise Error "Expected ']'" - return (PList () ps) - pPatParens0 = do - char '(' - inlineWhite - faasum' - [do char ')' - return (PTup () []) - ,do p <- pPattern0 0 - inlineWhite - faasum' - [do char ')' - return p - ,do char ',' - ps <- pPattern 0 `sepBy1` (inlineWhite >> char ',') - return (PTup () (p : ps))]] - -pELet0 :: FParser (Expr ()) -pELet0 = do - pKeyword "let" - 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" - 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" - 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 -> FParser (Expr ()) -pExprOpExpr d = inlineWhite >> pExprOpExpr0 d - -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 - -> FParser ParsedOperator -- ^ Parse an operator - -> (e -> Operator -> e -> e) -- ^ Build an operator application experssion - -> Int -- ^ Ambient precedence level: minimum precedence of top-level operator in result - -> e -- ^ lhs: Initial non-operator expression already parsed - -> Maybe ParsedOperator -- ^ Top-level operator in lhs (initialise with Nothing) - -> FParser e -climbRight pExpr' pOper makeOp d lhs mlhsop = - facatch (return lhs) $ do - paop@(PaOp op d2 a2) <- pOper - faguard (d2 >= d) -- respect global minimum precedence - case mlhsop of -- check operator compatibility - Just (PaOp _ d1 a1) -> - faguard (d1 > d2 || (d1 == d2 && a1 == a2 && a1 /= AssocNone)) - Nothing -> - return () - let oprhsd = case a2 of AssocRight -> d2 ; _ -> d2 + 1 - rhs <- pExpr' oprhsd - climbRight pExpr' pOper makeOp d (makeOp lhs op rhs) (Just paop) - -pEApp0 :: FParser (Expr ()) -pEApp0 = do - e1 <- pEAtom0 - es <- noFail $ famany (inlineWhite >> pEAtom0) - case es of - [] -> return e1 - _ -> return (EApp () e1 es) - -pEAtom0 :: FParser (Expr ()) -pEAtom0 = faasum' - [ELit () <$> pLiteral0 - ,pEList0 - ,pEVarOrCon0 - ,pEParens0] - -pLiteral0 :: FParser Literal -pLiteral0 = faasum' - [do as <- toList <$> fasome (satisfy isDigit) - let a = read as :: Integer - 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 '\'' - 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 '"' - noFail $ do - s <- famany pStringChar - char '"' <|>> raise Error "Unclosed string literal" - return (LString s)] - -pStringChar :: FParser Char -pStringChar = faasum' - [do char '\\' - char 'x' - let hexdig = do - c <- satisfy $ \c' -> - let c = toLower c' - 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 <- toList <$> fasome hexdig - return (chr (sum (zipWith (*) (reverse digs) (iterate (*16) 1)))) - ,do char '\\' - satisfy (const True) >>= \case - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'a' -> return '\a' - 'b' -> return '\b' - '\'' -> return '\'' - '\"' -> return '\"' - '0' -> return '\0' - c -> do raise Error $ "Invalid escape sequence: \\" ++ [c] - return '?' - ,do satisfy (\c -> c `notElem` "\n\r\\\'")] - -pEList0 :: FParser (Expr ()) -pEList0 = do - char '[' -- special syntax, no need for pKeySym - noFail $ do - es <- sepBy pExpr (inlineWhite >> char ',') - inlineWhite - char ']' <|>> raise Error "Expected closing ']'" - return (EList () es) - -pEVarOrCon0 :: FParser (Expr ()) -pEVarOrCon0 = - pIdentifier0 InBlock Don'tCare () >>= \case - (Lowercase, name) -> return (EVar () name) - (Uppercase, name) -> return (ECon () name) - -pEParens0 :: FParser (Expr ()) -pEParens0 = do - char '(' - noFail $ do - e <- pExpr <|>> (raise Error "Expected expression" >> return (ETup () [])) - inlineWhite - char ')' <|>> raise Error "Expected closing ')'" - return e - -data Associativity = AssocLeft | AssocRight | AssocNone - deriving (Show, Eq) - -data ParsedOperator = PaOp Operator Int Associativity - deriving (Show) - -pInfixOp :: Case care -> FParser (WithCaseOutput care ParsedOperator) -pInfixOp cs = do - inlineWhite - case cs of - Lowercase -> pLowerInfixOp0 - Uppercase -> pUpperInfixOp0 - Don'tCare -> faasum' [(Lowercase,) <$> pLowerInfixOp0 - ,(Uppercase,) <$> pUpperInfixOp0] - -pLowerInfixOp0 :: FParser ParsedOperator -pLowerInfixOp0 = - faasum' [PaOp OEqu 4 AssocNone <$ pKeySym "==" - ,PaOp OAdd 6 AssocLeft <$ pKeySym "+" - ,PaOp OSub 6 AssocLeft <$ pKeySym "-" - ,PaOp OMul 7 AssocLeft <$ pKeySym "*" - ,PaOp ODiv 7 AssocLeft <$ pKeySym "/" - ,PaOp OMod 7 AssocLeft <$ pKeySym "%" - ,PaOp OPow 8 AssocRight <$ pKeySym "^" - ] - -pUpperInfixOp0 :: FParser ParsedOperator -pUpperInfixOp0 = - faasum' [PaOp OCons 5 AssocRight <$ pKeySym ":"] - -pStandaloneTypesig0 :: FParser (Name, Type) -pStandaloneTypesig0 = do - name <- pIdentifier0 AtLeft Lowercase WCBacktrack - inlineWhite - pKeySym "::" - noFail $ pushContext ("type signature for " ++ pretty name) $ do - ty <- pType <|>> (raise Error "Expected type" >> return (TTup [])) - return (name, ty) - -pType :: FParser Type -pType = do - ty1 <- pTypeApp - facatch (return ty1) $ do - inlineWhite - pKeySym "->" - noFail $ do - ty2 <- pType <|>> (raise Error "Expected type" >> return (TTup [])) - return (TFun ty1 ty2) - -pTypeApp :: FParser Type -pTypeApp = fasome pTypeAtom >>= \case - t :| [] -> return t - t :| ts -> return (TApp t ts) - -pTypeAtom :: FParser Type -pTypeAtom = faasum' [pTypeParens, pTypeList, pTypeName] - where - pTypeParens = do - inlineWhite - char '(' - faasum' - [do inlineWhite - char ')' - return (TTup []) - ,do ty1 <- pType - noFail $ do - ty2s <- famany $ do - inlineWhite - char ',' - noFail $ pType <|>> (raise Error "Expected type" >> return (TTup [])) - inlineWhite - char ')' <|>> raise Error "Expected closing ')'" - case ty2s of - [] -> return ty1 - _ -> return (TTup (ty1 : ty2s))] - - pTypeList = do - inlineWhite - char '[' - ty <- pType - noFail $ char ']' <|>> raise Error "Expecte closing ']'" - return (TList ty) - - pTypeName = do - inlineWhite - (cs, name) <- pIdentifier0 InBlock Don'tCare () - case cs of - Uppercase -> return (TCon name) - Lowercase -> return (TVar name) - --- | Parse the given name-like keyword, ensuring that it is the entire word. -pKeyword :: String -> FParser () -pKeyword s = do - string s - -- traceM $ "pKeyword: parsed " ++ show s - notFollowedBy (() <$ satisfy isNameContChar) - --- | Parse the given symbol-like keyword, ensuring that it is the entire symbol. -pKeySym :: String -> FParser () -pKeySym s = do - string s - notFollowedBy (() <$ satisfy isSymbolChar) - -data Case care where - Uppercase :: Case 'True - Lowercase :: Case 'True - Don'tCare :: Case 'False -deriving instance Show (Case care) - -type family WithCaseOutput care a where - WithCaseOutput 'True a = a - WithCaseOutput 'False a = (Case 'True, a) - -type family If c a b where - If 'True a b = a - If 'False a b = b - -data WrongCaseBacktrack - = WCBacktrack -- ^ If a word was found but it had the wrong case, fail and backtrack. - | WCAssume -- ^ Be certain that this case is expected here, and assume incorrect - -- case is a typo. - deriving (Show) - --- | Consumes an identifier (word or parenthesised operator) at the current --- position. The `var` production in Haskell2010. --- var -> varid | "(" varsym ")" -pIdentifier0 :: BlockPos -> Case care -> If care WrongCaseBacktrack () -> FParser (WithCaseOutput care Name) -pIdentifier0 bpos cs wrongcase = - pAlphaName0 bpos cs wrongcase <|>> pParens0 (pSymbol0 bpos cs) - where - -- | Parser between parens, with the opening paren at the current position. - pParens0 :: FParser a -> FParser a - pParens0 p = do - char '(' - inlineWhite - res <- p - inlineWhite - char ')' - return res - --- | Consumes a word-like name at the current position with the given case. The --- `varid` production in Haskell2010 for 'Lowercase', `conid' for 'Uppercase'. --- --- > varid -> (small {small | large | digit | "'"}) without reservedid -pAlphaName0 :: BlockPos -> Case care -> If care WrongCaseBacktrack () -> FParser (WithCaseOutput care Name) -pAlphaName0 bpos cs wrongcase = do - startPos <- gets psCur - (_, s) <- readToken - bpos - (\atfst mc -> case (atfst, mc) of - (True , Just c) | isNameHeadChar c -> Just (Right False) - (True , _ ) -> Nothing - (False, Just c) | isNameContChar c -> Just (Right False) - (False, _ ) -> Just (Left ())) - True - faguard (s `notElem` ["case", "class", "data", "default", "deriving", "do", "else" - ,"foreign", "if", "import", "in", "infix", "infixl" - ,"infixr", "instance", "let", "module", "newtype", "of" - ,"then", "type", "where", "_"]) - (name, adjoin) <- case cs of - Uppercase - | isLower (head s) -> case wrongcase of - WCBacktrack -> faempty - WCAssume -> noFail $ do - raiseAt startPos Error "Unexpected uppercase word at this position, assuming typo" - return (toUpper (head s) : tail s, id) - | otherwise -> return (s, id) - Lowercase - | isUpper (head s) -> case wrongcase of - WCBacktrack -> faempty - WCAssume -> noFail $ do - raiseAt startPos Error "Unexpected lowercase word at this position, assuming typo" - return (toLower (head s) : tail s, id) - | otherwise -> return (s, id) - Don'tCare - | isLower (head s) -> return (s, (Lowercase,)) - | otherwise -> return (s, (Uppercase,)) - return (adjoin (Name name)) - -isNameHeadChar :: Char -> Bool -isNameHeadChar c = isLetter c || c == '_' - -isNameContChar :: Char -> Bool -isNameContChar c = isNameHeadChar c || isDigit c || c == '\'' - --- | Consumes a symbol at the current position. The `varsym` production in --- Haskell2010 for 'Lowercase', `consym` otherwise, and either if 'Don'tCare'. --- --- > varsym -> ((symbol without ":") {symbol}) without (reservedop | dashes) --- > consym -> (":" {symbol}) without reservedop --- > symbol -> ascSymbol | uniSymbol without (special | "_" | "\"" | "'") --- > ascSymbol -> ```!#$%&⋆+./<=>?@^|-~:``` --- > uniSymbol -> unicode symbol or punctuation --- > dashes -> "--" {"-"} --- > special -> ```(),;[]`{}``` --- > reservedop -> ".." | ":" | "::" | "=" | "\" | "|" | "<-" | "->" | "@" | "~" | "=>" -pSymbol0 :: BlockPos -> Case care -> FParser (WithCaseOutput care Name) -pSymbol0 bpos cs = do - case bpos of - 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 (== ':') - Don'tCare -> do c1 <- satisfy (\c -> isSymbolChar c) - return (c1, if c1 == ':' then (Uppercase,) else (Lowercase,)) - crest <- noFail $ famany (satisfy isSymbolChar) - let name = c1 : crest - faguard (name `notElem` ["..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]) - faguard (take 2 name /= "--") - return (adjoin (Name name)) - -isSymbolChar :: Char -> Bool -isSymbolChar c = (isAscSymbol || isUniSymbol) && not isSpecialExt - where - isSpecialExt = c `elem` "(),;[]`{}_\"'" - isAscSymbol = c `elem` "!#$%&⋆+./<=>?@^|-~:" - isUniSymbol = ord c > 127 && (isSymbol c || isPunctuation c) - - -sepBy1 :: FParser a -> FParser sep -> FParser [a] -sepBy1 p psep = do - x1 <- p - (psep >> (x1 :) <$> sepBy1 p psep) <|>> pure [x1] - -sepBy :: FParser a -> FParser sep -> IParser [a] -sepBy p psep = sepBy1 p psep <|>> pure [] - --- | Start a new layout block at the current position. The old layout block is --- restored after completion of this subparser. -startLayoutBlock :: IParser a -> IParser a -startLayoutBlock p = do - ps0 <- get - put (ps0 { psBlk = psCur ps0 }) - res <- p - modify (\ps -> ps { psBlk = psBlk ps0 }) - return res - -data Fatality fatal where - Error :: Fatality 'False - Fatal :: Fatality 'True -deriving instance Show (Fatality fatal) - -type family FatalCtx fatal a where - FatalCtx 'False a = a ~ () - FatalCtx 'True a = () - -raise_ :: KnownFallible fail => Fatality fatal -> String -> Parser fail () -raise_ Error = raise Error -raise_ Fatal = raise Fatal - -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 :: (KnownFallible fail, FatalCtx fatal a) => Pos -> Fatality fatal -> String -> Parser fail a -raiseAt pos fat msg = do - Context { ctxFile = fp , ctxStack = stk, ctxLines = srcLines } <- ask - let err = ErrMsg fp stk pos msg (srcLines !! posLine pos) - case fat of - Error -> dictate (pure err) - Fatal -> confess (pure err) - -describeLocation :: IParser String -describeLocation = do - fp <- asks ctxFile - cur <- gets psCur - return $ fp ++ ":" ++ show (posLine cur + 1) ++ ":" ++ show (posCol cur + 1) - --- | Registers a scope description on the stack for error reporting. -pushContext :: String -> Parser fail a -> Parser fail a -pushContext descr = local (\c -> c { ctxStack = descr : ctxStack c }) - --- | Registers a scope description on the stack for error reporting, suffixed --- with the current parsing location. -pushLocatedContext :: String -> Parser fail a -> Parser fail a -pushLocatedContext descr p = do - loc <- noFail describeLocation - pushContext (descr ++ " at " ++ loc) p - -data BlockPos = AtLeft | InBlock - deriving (Show) - --- | Consumes a token at the current position, asserting that we are --- in the position indicated by the 'BlockPos' argument. The token is defined --- by a pure stateful parser. If encountering a newline or EOF, the parser is --- run on this character ('Nothing' for EOF); if this produces a result, the --- result is returned; otherwise, the parser fails. The newline is not consumed. -readToken :: BlockPos -> (s -> Maybe Char -> Maybe (Either r s)) -> s -> FParser (r, String) -readToken bpos f s0 = do - case bpos of - 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 - case psRest ps of - [] | Just (Left res) <- f' st Nothing -> return (res, "") - | otherwise -> faempty - '\n' : _ | Just (Left res) <- f' st (Just '\n') -> return (res, "") - c : cs -> case f' st (Just c) of - Nothing -> faempty - Just (Left res) -> return (res, "") - Just (Right st') -> do - let Pos line col = psCur ps - put (ps { psCur = Pos line (col + 1), psRest = cs }) - fmap (c :) <$> loop f' st' - loop f s0 - --- | Consumes all whitespace and comments (including newlines), but only if --- this then leaves the parser inside the current block. If not, succeeds and --- consumes nothing. -inlineWhite :: Parser fail () -inlineWhite = do - ps <- get - noFail skipWhiteComment - whenM (noFail $ not <$> isInsideBlock) $ put ps - --- | Consumes all whitespace and comments (including newlines). Note: this may --- end outside the current block. -skipWhiteComment :: IParser () -skipWhiteComment = do - inlineSpaces - _ <- famany (blockComment >> noFail inlineSpaces) - optional_ lineComment - optional_ (consumeNewline >> noFail skipWhiteComment) - where - -- | Consumes some inline whitespace. Stops before newlines. - inlineSpaces :: IParser () - inlineSpaces = readWhileInline isSpace - --- | Consumes an delimited comment including both end markers. Note: this may --- end outside the current block. -blockComment :: FParser () -blockComment = do - string "{-" -- no need for pKeySym here - let loop = do - faasum [string "-}" - ,eof >> raise Error "Unfinished {- -} comment at end of file" - ,blockComment >> noFail loop - ,consumeNewline >> noFail loop] - (readWhileInline (`notElem` "{-")) -- "-}" also starts with '-' - noFail loop - --- | Consumes a line comment marker and the rest of the line, excluding --- newline. -lineComment :: FParser () -lineComment = do - -- '--!' is an operator, so we need to parse a whole symbol here. - pKeySym "--" - noFail $ readWhileInline (const True) - --- | Raises an error if we're not currently at EOF. -assertEOF :: Fatality fatal -> IParser () -assertEOF fat = gets psRest >>= \case - [] -> return () - _ -> raise_ fat "Unexpected stuff" - --- | Returns whether the current position is _within_ the current block, for --- soft-wrapping content. This means that col > blkCol. -isInsideBlock :: IParser Bool -isInsideBlock = do - PS { psCur = cur, psBlk = blk } <- get - return $ posLine cur >= posLine blk && posCol cur > posCol blk - --- | Returns whether the current position is at the left border of the block; --- this is for list content such as function definitions or let bindings. This --- means that col == blkCol. -isAtBlockLeft :: IParser Bool -isAtBlockLeft = do - PS { psCur = cur, psBlk = blk } <- get - return $ posLine cur >= posLine blk && posCol cur == posCol blk - --- | Consumes characters while the predicate holds or until (and excluding) --- a newline, whichever comes first. -readWhileInline :: (Char -> Bool) -> IParser () -readWhileInline p = do - (taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest - modify (\ps -> ps { psCur = let Pos line col = psCur ps - in Pos line (col + length taken) - , psRest = rest }) - --- | Consumes exactly one newline at the current position. -consumeNewline :: FParser () -consumeNewline = gets psRest >>= \case - '\n' : rest -> modify (\ps -> ps { psCur = Pos (posLine (psCur ps) + 1) 0 - , psRest = rest }) - _ -> faempty - --- | Consumes exactly one character, unequal to newline, at the current position. -satisfy :: (Char -> Bool) -> FParser Char -satisfy p = do - -- traceM "entering satisfy" - r <- gets psRest - -- traceM "got rest" - r `seq` return () - -- traceM "seqd rest" - -- traceM ("rest is " ++ show r) - case r of - c : rest | c /= '\n', p c -> do - modify (\ps -> let Pos line col = psCur ps - in ps { psCur = Pos line (col + 1) - , psRest = rest }) - return c - _ -> faempty - --- | Consumes exactly this character at the current position. Must not be a --- newline. -char :: Char -> FParser () -char c = string [c] - --- | Consumes exactly this string at the current position. The string must not --- contain a newline. -string :: String -> FParser () -string s | any (== '\n') s = error "Newline in 'string' argument" -string s = do - ps <- get - let Pos line col = psCur ps - if take (length s) (psRest ps) == s - then put (ps { psCur = Pos line (col + length s) - , 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 - -notFollowedBy :: FParser () -> FParser () -notFollowedBy p = do - ps <- get - success <- (False <$ p) <|>> pure True - put ps -- restore state, as if nothing happened - when (not success) faempty - --- | Only succeeds at EOF. -eof :: FParser () -eof = gets psRest >>= \case [] -> return () - _ -> faempty - -whenM :: (Monad m, Monoid a) => m Bool -> m a -> m a -whenM mb mx = mb >>= \b -> if b then mx else return mempty - -optional_ :: FAlternative f => f 'Fallible a -> f 'Infallible () -optional_ a = (() <$ a) <|>> pure () -- cgit v1.2.3-70-g09d2