diff options
| -rw-r--r-- | AST.hs | 48 | ||||
| -rw-r--r-- | Main.hs | 26 | ||||
| -rw-r--r-- | Parser.hs | 798 |
3 files changed, 437 insertions, 435 deletions
@@ -11,42 +11,42 @@ newtype Name = Name String deriving (Show, Eq) data Type - = TApp Type [Type] - | TTup [Type] - | TList Type - | TFun Type Type - | TCon Name - | TVar Name + = TApp Type [Type] + | TTup [Type] + | TList Type + | TFun Type Type + | TCon Name + | TVar Name deriving (Show) data FunEq t = FunEq Name [Pattern t] (RHS t) deriving (Show) data Pattern t - = PWildcard t - | PVar t Name - | PAs t Name (Pattern t) - | PCon t Name [Pattern t] - | PList t [Pattern t] - | PTup t [Pattern t] + = PWildcard t + | PVar t Name + | PAs t Name (Pattern t) + | PCon t Name [Pattern t] + | PList t [Pattern t] + | PTup t [Pattern t] deriving (Show) data RHS t - = Guarded [(Expr t, Expr t)] - | Plain (Expr t) + = Guarded [(Expr t, Expr t)] + | Plain (Expr t) deriving (Show) data Expr t - = ELit t Literal - | EVar t Name - | ECon t Name - | EList t [Expr t] - | ETup t [Expr t] - | EApp t (Expr t) [Expr t] - | EOp t (Expr t) Operator (Expr t) - | EIf t (Expr t) (Expr t) (Expr t) - | ECase t (Expr t) [(Pattern t, RHS t)] - | ELet t [FunDef t] (Expr t) + = ELit t Literal + | EVar t Name + | ECon t Name + | EList t [Expr t] + | ETup t [Expr t] + | EApp t (Expr t) [Expr t] + | EOp t (Expr t) Operator (Expr t) + | EIf t (Expr t) (Expr t) (Expr t) + | ECase t (Expr t) [(Pattern t, RHS t)] + | ELet t [FunDef t] (Expr t) deriving (Show) data Literal = LInt Integer | LFloat Rational | LChar Char | LString String @@ -10,18 +10,18 @@ import Parser main :: IO () main = do - (source, fname) <- getArgs >>= \case - [] -> (,"<stdin>") <$> getContents - [fname] -> (,fname) <$> readFile fname - _ -> die "Usage: hs-visinter [filename.hs]" + (source, fname) <- getArgs >>= \case + [] -> (,"<stdin>") <$> getContents + [fname] -> (,fname) <$> readFile fname + _ -> die "Usage: hs-visinter [filename.hs]" - prog <- case parse fname source of - This errs -> do - mapM_ (putStrLn . printErrMsg) errs - exitFailure - These errs res -> do - mapM_ (putStrLn . printErrMsg) errs - return res - That res -> return res + prog <- case parse fname source of + This errs -> do + mapM_ (putStrLn . printErrMsg) errs + exitFailure + These errs res -> do + mapM_ (putStrLn . printErrMsg) errs + return res + That res -> return res - print prog + print prog @@ -8,10 +8,10 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} module Parser ( - parse, - printErrMsg, - -- * Re-exports - These(..), + parse, + printErrMsg, + -- * Re-exports + These(..), ) where import Control.Applicative @@ -32,18 +32,18 @@ import AST -- See 'isInsideBlock' and 'isAtBlockLeft' for the two relevant "inside the -- block" conditions. data PS = PS - { psBlkLine :: Int -- ^ Start line of current layout block - , psBlkCol :: Int -- ^ Start column of current layout block - , psLine :: Int -- ^ Current line - , psCol :: Int -- ^ Current column - , psRest :: String -- ^ Rest of the input - } + { psBlkLine :: Int -- ^ Start line of current layout block + , psBlkCol :: Int -- ^ Start column of current layout block + , psLine :: Int -- ^ Current line + , psCol :: Int -- ^ Current column + , psRest :: String -- ^ Rest of the input + } deriving (Show) data Context = Context - { ctxFile :: FilePath - , ctxStack :: [String] -- ^ Stack of syntax scopes, for error reporting - } + { ctxFile :: FilePath + , ctxStack :: [String] -- ^ Stack of syntax scopes, for error reporting + } deriving (Show) -- ReaderT Context (ChronicleT [ErrMsg] (State PS) a) @@ -57,87 +57,88 @@ data Context = Context newtype Parser a = Parser { runParser :: Context -> PS -> These [ErrMsg] (PS, a) } instance Functor Parser where - fmap f (Parser g) = Parser (\ctx ps -> fmap (fmap f) (g ctx ps)) + fmap f (Parser g) = Parser (\ctx ps -> fmap (fmap f) (g ctx ps)) instance Applicative Parser where - pure x = Parser (\_ ps -> That (ps, x)) - (<*>) = ap + pure x = Parser (\_ ps -> That (ps, x)) + (<*>) = ap instance Monad Parser where - Parser g >>= f = Parser $ \ctx ps -> - case g ctx ps of - This errs -> This errs - That (ps', x) -> runParser (f x) ctx ps' - These errs (ps', x) -> case runParser (f x) ctx ps' of - This errs' -> This (errs <> errs') - That res -> These errs res - These errs' res -> These (errs <> errs') res + Parser g >>= f = Parser $ \ctx ps -> + case g ctx ps of + This errs -> This errs + That (ps', x) -> runParser (f x) ctx ps' + These errs (ps', x) -> case runParser (f x) ctx ps' of + This errs' -> This (errs <> errs') + That res -> These errs res + These errs' res -> These (errs <> errs') res instance Alternative Parser where - empty = Parser (\_ _ -> This mempty) - Parser f <|> Parser g = Parser $ \ctx ps -> - case f ctx ps of - This _ -> g ctx ps - success -> success + empty = Parser (\_ _ -> This mempty) + Parser f <|> Parser g = Parser $ \ctx ps -> + case f ctx ps of + This _ -> g ctx ps + success -> success instance MonadState PS Parser where - state f = Parser $ \_ ps -> That (swap (f ps)) + state f = Parser $ \_ ps -> That (swap (f ps)) instance MonadReader Context Parser where - reader f = Parser $ \ctx ps -> That (ps, f ctx) - local f (Parser g) = Parser (g . f) + reader f = Parser $ \ctx ps -> That (ps, f ctx) + local f (Parser g) = Parser (g . f) instance MonadChronicle [ErrMsg] Parser where - dictate errs = Parser (\_ ps -> These errs (ps, ())) - confess errs = Parser (\_ _ -> This errs) - memento (Parser f) = Parser (\ctx ps -> case f ctx ps of - This errs -> That (ps, Left errs) - That res -> That (Right <$> res) - These errs res -> These errs (Right <$> res)) - absolve def (Parser f) = Parser (\ctx ps -> case f ctx ps of - This _ -> That (ps, def) - success -> success) - condemn (Parser f) = Parser (\ctx ps -> case f ctx ps of - These errs _ -> This errs - res -> res) - retcon g (Parser f) = Parser (\ctx ps -> first g (f ctx ps)) - chronicle th = Parser (\_ ps -> (ps,) <$> th) + dictate errs = Parser (\_ ps -> These errs (ps, ())) + confess errs = Parser (\_ _ -> This errs) + memento (Parser f) = Parser (\ctx ps -> case f ctx ps of + This errs -> That (ps, Left errs) + That res -> That (Right <$> res) + These errs res -> These errs (Right <$> res)) + absolve def (Parser f) = Parser (\ctx ps -> case f ctx ps of + This _ -> That (ps, def) + success -> success) + condemn (Parser f) = Parser (\ctx ps -> case f ctx ps of + These errs _ -> This errs + res -> res) + retcon g (Parser f) = Parser (\ctx ps -> first g (f ctx ps)) + chronicle th = Parser (\_ ps -> (ps,) <$> th) -- Positions are zero-based in both dimensions -data ErrMsg = ErrMsg { errFile :: FilePath - , errStk :: [String] - , errLine :: Int - , errCol :: Int - , errMsg :: String } +data ErrMsg = ErrMsg + { errFile :: FilePath + , errStk :: [String] + , errLine :: Int + , errCol :: Int + , errMsg :: String } deriving (Show) printErrMsg :: ErrMsg -> String printErrMsg (ErrMsg fp stk y x s) = - unlines (map (\descr -> "In " ++ descr ++ ":") (reverse stk)) ++ - fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s + unlines (map (\descr -> "In " ++ descr ++ ":") (reverse stk)) ++ + fp ++ ":" ++ show (y + 1) ++ ":" ++ show (x + 1) ++ ": " ++ s parse :: FilePath -> String -> These [ErrMsg] (Program ()) parse fp source = fmap snd $ runParser pProgram (Context fp []) (PS 0 0 0 0 source) pProgram :: Parser (Program ()) pProgram = do - prog <- Program <$> many pFunDef - skipWhiteComment - assertEOF Error - return prog + prog <- Program <$> many pFunDef + skipWhiteComment + assertEOF Error + return prog pFunDef :: Parser (FunDef ()) pFunDef = do - skipWhiteComment - pFunDef0 + skipWhiteComment + pFunDef0 pFunDef0 :: Parser (FunDef ()) pFunDef0 = do - mtypesig <- optional pStandaloneTypesig0 - let mname = fst <$> mtypesig - mtype = snd <$> mtypesig - (clauses, name) <- someClauses mname - return (FunDef name mtype clauses) + mtypesig <- optional pStandaloneTypesig0 + let mname = fst <$> mtypesig + mtype = snd <$> mtypesig + (clauses, name) <- someClauses mname + return (FunDef name mtype clauses) where someClauses :: Maybe Name -> Parser ([FunEq ()], Name) someClauses Nothing = do @@ -148,227 +149,227 @@ pFunDef0 = do -- | Given the name of the type signature, if any. pFunEq :: Maybe Name -> Parser (FunEq ()) pFunEq mCheckName = do - skipWhiteComment - assertAtBlockLeft Fatal "Expected function clause, found indented stuff" + skipWhiteComment + assertAtBlockLeft Fatal "Expected function clause, found indented stuff" - name <- pIdentifier0 AtLeft Lowercase - case mCheckName of - Just checkName | name /= checkName -> - raise Fatal "Name of function clause does not correspond with type signature" - _ -> return () + name <- pIdentifier0 AtLeft Lowercase + case mCheckName of + Just checkName | name /= checkName -> + raise Fatal "Name of function clause does not correspond with type signature" + _ -> return () - pats <- many (pPattern 11) - rhs <- pRHS "=" - return (FunEq name pats rhs) + pats <- many (pPattern 11) + rhs <- pRHS "=" + return (FunEq name pats rhs) -- | Pass "=" for function definitions and "->" for case clauses. pRHS :: String -> Parser (RHS ()) pRHS sepsym = do - -- TODO: parse guards - inlineWhite - pKeySym sepsym - Plain <$> pExpr + -- TODO: parse guards + inlineWhite + pKeySym sepsym + Plain <$> pExpr pPattern :: Int -> Parser (Pattern ()) pPattern d = inlineWhite >> pPattern0 d pPattern0 :: Int -> Parser (Pattern ()) pPattern0 d = do - asum [pPatWildcard0 - ,pPatVarOrAs0 - ,pPatCon0 - ,pPatList0 - ,pPatParens0] + asum [pPatWildcard0 + ,pPatVarOrAs0 + ,pPatCon0 + ,pPatList0 + ,pPatParens0] where pPatWildcard0 = pKeySym "_" >> return (PWildcard ()) pPatVarOrAs0 = do - var <- pIdentifier0 InBlock Lowercase - asum [do inlineWhite - pKeySym "@" - p <- pPattern 11 - return (PAs () var p) - ,return (PVar () var)] + var <- pIdentifier0 InBlock Lowercase + asum [do inlineWhite + pKeySym "@" + p <- pPattern 11 + return (PAs () var p) + ,return (PVar () var)] pPatCon0 = do - con <- pIdentifier0 InBlock Uppercase - if d > 0 - then return (PCon () con []) - else do args <- many (pPattern 11) - return (PCon () con args) + con <- pIdentifier0 InBlock Uppercase + if d > 0 + then return (PCon () con []) + else do args <- many (pPattern 11) + return (PCon () con args) pPatList0 = do - char '[' -- special syntax, no need for pKeySym - ps <- pPattern 0 `sepBy` (inlineWhite >> char ',') - inlineWhite - char ']' - return (PList () ps) + char '[' -- special syntax, no need for pKeySym + ps <- pPattern 0 `sepBy` (inlineWhite >> char ',') + inlineWhite + char ']' + return (PList () ps) pPatParens0 = do - char '(' - inlineWhite - asum [do char ')' - return (PTup () []) - ,do p <- pPattern0 0 - inlineWhite - asum [do char ')' - return p - ,do char ',' - ps <- pPattern 0 `sepBy1` (inlineWhite >> char ',') - return (PTup () (p : ps))]] + char '(' + inlineWhite + asum [do char ')' + return (PTup () []) + ,do p <- pPattern0 0 + inlineWhite + asum [do char ')' + return p + ,do char ',' + ps <- pPattern 0 `sepBy1` (inlineWhite >> char ',') + return (PTup () (p : ps))]] pExpr :: Parser (Expr ()) pExpr = do - inlineWhite - -- basics: lit, list, var, con, tup - -- expression atom: application of basics - -- expression parser: op - -- around: let, case, if - asum [pELet0 - ,pECase0 - ,pEIf0 - ,pExprOpExpr0 0] + inlineWhite + -- basics: lit, list, var, con, tup + -- expression atom: application of basics + -- expression parser: op + -- around: let, case, if + asum [pELet0 + ,pECase0 + ,pEIf0 + ,pExprOpExpr0 0] pELet0 :: Parser (Expr ()) pELet0 = do - pKeyword "let" + pKeyword "let" + inlineWhite + startLayoutBlock $ do + -- The first occurrence is also going to skip whitespace in front, + -- which is redundant -- but not harmful. + defs <- 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 <$ lookAhead (pKeyword "in") + ,Just <$> pFunDef0] + case res of + Nothing -> empty + Just def -> return def inlineWhite - startLayoutBlock $ do - -- The first occurrence is also going to skip whitespace in front, - -- which is redundant -- but not harmful. - defs <- 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 <$ lookAhead (pKeyword "in") - ,Just <$> pFunDef0] - case res of - Nothing -> empty - Just def -> return def - inlineWhite - body <- pExpr - return (ELet () defs body) + body <- pExpr + return (ELet () defs body) pECase0 :: Parser (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) + 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 :: Parser (Expr ()) pEIf0 = do - pKeyword "if" - e1 <- pExpr - inlineWhite - pKeyword "then" - e2 <- pExpr - inlineWhite - pKeyword "else" - e3 <- pExpr - return (EIf () e1 e2 e3) + pKeyword "if" + e1 <- pExpr + inlineWhite + pKeyword "then" + e2 <- pExpr + inlineWhite + pKeyword "else" + e3 <- pExpr + return (EIf () e1 e2 e3) pExprOpExpr :: Int -> Parser (Expr ()) pExprOpExpr d = inlineWhite >> pExprOpExpr0 d pExprOpExpr0 :: Int -> Parser (Expr ()) pExprOpExpr0 d = do - e0 <- pEApp0 - climbRight e0 Nothing + e0 <- pEApp0 + climbRight e0 Nothing where climbRight :: Expr () -> Maybe ParsedOperator -> Parser (Expr ()) climbRight lhs mlhsop = do - asum [do paop@(PaOp op d2 a2) <- pInfixOp - guard (d2 >= d) -- respect global minimum precedence - case mlhsop of -- check operator compatibility - Just (PaOp _ d1 a1) -> - guard (d1 > d2 || (d1 == d2 && a1 == a2 && a1 /= AssocNone)) - Nothing -> - return () - let oprhsd = case a2 of AssocRight -> d2 ; _ -> d2 + 1 - rhs <- pExprOpExpr oprhsd - climbRight (EOp () lhs op rhs) (Just paop) - ,return lhs] + asum [do paop@(PaOp op d2 a2) <- pInfixOp + guard (d2 >= d) -- respect global minimum precedence + case mlhsop of -- check operator compatibility + Just (PaOp _ d1 a1) -> + guard (d1 > d2 || (d1 == d2 && a1 == a2 && a1 /= AssocNone)) + Nothing -> + return () + let oprhsd = case a2 of AssocRight -> d2 ; _ -> d2 + 1 + rhs <- pExprOpExpr oprhsd + climbRight (EOp () lhs op rhs) (Just paop) + ,return lhs] pEApp0 :: Parser (Expr ()) pEApp0 = do - e1 <- pEAtom0 - es <- many (inlineWhite >> pEAtom0) - case es of - [] -> return e1 - _ -> return (EApp () e1 es) + e1 <- pEAtom0 + es <- many (inlineWhite >> pEAtom0) + case es of + [] -> return e1 + _ -> return (EApp () e1 es) pEAtom0 :: Parser (Expr ()) pEAtom0 = (ELit () <$> pLiteral0) <|> pEList0 <|> pEVar0 <|> pECon0 <|> pEParens0 pLiteral0 :: Parser Literal pLiteral0 = asum - [do as <- some (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)] - ,do char '\'' - c <- pStringChar - char '\'' - return (LChar c) - ,do char '"' - s <- many pStringChar - char '"' - return (LString s)] + [do as <- some (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)] + ,do char '\'' + c <- pStringChar + char '\'' + return (LChar c) + ,do char '"' + s <- many pStringChar + char '"' + return (LString s)] pStringChar :: Parser Char pStringChar = asum - [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 <- some 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\\\'")] + [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 <- some 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 :: Parser (Expr ()) pEList0 = do - char '[' -- special syntax, no need for pKeySym - es <- sepBy pExpr (inlineWhite >> char ',') - inlineWhite - char ']' - return (EList () es) + char '[' -- special syntax, no need for pKeySym + es <- sepBy pExpr (inlineWhite >> char ',') + inlineWhite + char ']' + return (EList () es) pEVar0 :: Parser (Expr ()) pEVar0 = EVar () <$> pIdentifier0 InBlock Lowercase @@ -378,11 +379,11 @@ pECon0 = ECon () <$> pIdentifier0 InBlock Uppercase pEParens0 :: Parser (Expr ()) pEParens0 = do - char '(' - e <- pExpr - inlineWhite - char ')' - return e + char '(' + e <- pExpr + inlineWhite + char ')' + return e data Associativity = AssocLeft | AssocRight | AssocNone deriving (Show, Eq) @@ -392,40 +393,40 @@ data ParsedOperator = PaOp Operator Int Associativity pInfixOp :: Parser ParsedOperator pInfixOp = do - inlineWhite - asum [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 "^" - ] + inlineWhite + asum [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 "^" + ] pStandaloneTypesig0 :: Parser (Name, Type) pStandaloneTypesig0 = do - assertAtBlockLeft Fatal "Expected top-level definition, found indented stuff" - name@(Name namestr) <- pIdentifier0 AtLeft Lowercase - inlineWhite - pKeySym "::" - pushContext ("type signature for '" ++ namestr ++ "'") $ do - ty <- pType - return (name, ty) + assertAtBlockLeft Fatal "Expected top-level definition, found indented stuff" + name@(Name namestr) <- pIdentifier0 AtLeft Lowercase + inlineWhite + pKeySym "::" + pushContext ("type signature for '" ++ namestr ++ "'") $ do + ty <- pType + return (name, ty) pType :: Parser Type pType = do - ty1 <- pTypeApp - asum [do inlineWhite - pKeySym "->" - ty2 <- pType - return (TFun ty1 ty2) - ,return ty1] + ty1 <- pTypeApp + asum [do inlineWhite + pKeySym "->" + ty2 <- pType + return (TFun ty1 ty2) + ,return ty1] pTypeApp :: Parser Type pTypeApp = many pTypeAtom >>= \case - [] -> raise Error "Expected type" >> return (TTup []) - [t] -> return t - t:ts -> return (TApp t ts) + [] -> raise Error "Expected type" >> return (TTup []) + [t] -> return t + t:ts -> return (TApp t ts) pTypeAtom :: Parser Type pTypeAtom = pTypeParens <|> pTypeList <|> pTypeCon <|> pTypeVar @@ -438,9 +439,9 @@ pTypeAtom = pTypeParens <|> pTypeList <|> pTypeCon <|> pTypeVar return (TTup []) ,do ty1 <- pType ty2s <- many $ do - inlineWhite - char ',' - pType + inlineWhite + char ',' + pType inlineWhite char ')' case ty2s of @@ -448,11 +449,11 @@ pTypeAtom = pTypeParens <|> pTypeList <|> pTypeCon <|> pTypeVar _ -> return (TTup (ty1 : ty2s))] pTypeList = do - inlineWhite - char '[' - ty <- pType - char ']' - return (TList ty) + inlineWhite + char '[' + ty <- pType + char ']' + return (TList ty) pTypeCon = inlineWhite >> TCon <$> pIdentifier0 InBlock Uppercase pTypeVar = inlineWhite >> TVar <$> pIdentifier0 InBlock Lowercase @@ -460,14 +461,14 @@ pTypeAtom = pTypeParens <|> pTypeList <|> pTypeCon <|> pTypeVar -- | Parse the given name-like keyword, ensuring that it is the entire word. pKeyword :: String -> Parser () pKeyword s = do - string s - notFollowedBy (() <$ satisfy isNameContChar) + string s + notFollowedBy (() <$ satisfy isNameContChar) -- | Parse the given symbol-like keyword, ensuring that it is the entire symbol. pKeySym :: String -> Parser () pKeySym s = do - string s - notFollowedBy (() <$ satisfy isSymbolChar) + string s + notFollowedBy (() <$ satisfy isSymbolChar) data Case = Uppercase | Lowercase deriving (Show) @@ -481,12 +482,12 @@ pIdentifier0 bpos cs = pAlphaName0 bpos cs <|> pParens0 (pSymbol0 bpos cs) -- | Parser between parens, with the opening paren at the current position. pParens0 :: Parser a -> Parser a pParens0 p = do - char '(' - inlineWhite - res <- p - inlineWhite - char ')' - return res + 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'. @@ -494,26 +495,27 @@ pIdentifier0 bpos cs = pAlphaName0 bpos cs <|> pParens0 (pSymbol0 bpos cs) -- > varid -> (small {small | large | digit | "'"}) without reservedid pAlphaName0 :: BlockPos -> Case -> Parser Name pAlphaName0 bpos cs = do - (_, 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 - name <- case cs of - Uppercase | isLower (head s) -> do - raise Error "Unexpected uppercase word at this position, assuming typo" - return (toUpper (head s) : tail s) - Lowercase | isUpper (head s) -> do - raise Error "Unexpected lowercase word at this position, assuming typo" - return (toLower (head s) : tail s) - _ -> return s - guard (name `notElem` ["case", "class", "data", "default", "deriving", "do", "else" - ,"foreign", "if", "import", "in", "infix", "infixl" - ,"infixr", "instance", "let", "module", "newtype", "of" - ,"then", "type", "where", "_"]) - return (Name name) + (_, 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 + name <- case cs of + Uppercase | isLower (head s) -> do + raise Error "Unexpected uppercase word at this position, assuming typo" + return (toUpper (head s) : tail s) + Lowercase | isUpper (head s) -> do + raise Error "Unexpected lowercase word at this position, assuming typo" + return (toLower (head s) : tail s) + _ -> return s + guard (name `notElem` ["case", "class", "data", "default", "deriving", "do", "else" + ,"foreign", "if", "import", "in", "infix", "infixl" + ,"infixr", "instance", "let", "module", "newtype", "of" + ,"then", "type", "where", "_"]) + return (Name name) isNameHeadChar :: Char -> Bool isNameHeadChar c = isLetter c || c == '_' @@ -534,15 +536,15 @@ isNameContChar c = isNameHeadChar c || isDigit c || c == '\'' -- > reservedop -> ".." | ":" | "::" | "=" | "\" | "|" | "<-" | "->" | "@" | "~" | "=>" pSymbol0 :: BlockPos -> Case -> Parser Name pSymbol0 bpos cs = do - case bpos of - AtLeft -> assertAtBlockLeft Fatal "Expected symbol, but found indented expression" - InBlock -> assertInsideBlock Fatal "Expected symbol, but found end of indented expression" - name <- (:) <$> (case cs of Lowercase -> satisfy (\c -> isSymbolChar c && c /= ':') - Uppercase -> satisfy (== ':')) - <*> many (satisfy isSymbolChar) - guard (name `notElem` ["..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]) - guard (take 2 name /= "--") - return (Name name) + case bpos of + AtLeft -> assertAtBlockLeft Fatal "Expected symbol, but found indented expression" + InBlock -> assertInsideBlock Fatal "Expected symbol, but found end of indented expression" + name <- (:) <$> (case cs of Lowercase -> satisfy (\c -> isSymbolChar c && c /= ':') + Uppercase -> satisfy (== ':')) + <*> many (satisfy isSymbolChar) + guard (name `notElem` ["..", ":", "::", "=", "\\", "|", "<-", "->", "@", "~", "=>"]) + guard (take 2 name /= "--") + return (Name name) isSymbolChar :: Char -> Bool isSymbolChar c = (isAscSymbol || isUniSymbol) && not isSpecialExt @@ -554,8 +556,8 @@ isSymbolChar c = (isAscSymbol || isUniSymbol) && not isSpecialExt sepBy1 :: Parser a -> Parser sep -> Parser [a] sepBy1 p psep = do - x1 <- p - (psep >> (x1 :) <$> sepBy1 p psep) <|> return [x1] + x1 <- p + (psep >> (x1 :) <$> sepBy1 p psep) <|> return [x1] sepBy :: Parser a -> Parser sep -> Parser [a] sepBy p psep = sepBy1 p psep <|> return [] @@ -564,32 +566,32 @@ sepBy p psep = sepBy1 p psep <|> return [] -- restored after completion of this subparser. startLayoutBlock :: Parser a -> Parser a startLayoutBlock p = do - ps0 <- get - put (ps0 { psBlkLine = psLine ps0 - , psBlkCol = psCol ps0 }) - res <- p - modify (\ps -> ps { psBlkLine = psBlkLine ps0 - , psBlkCol = psBlkCol ps0 }) - return res + ps0 <- get + put (ps0 { psBlkLine = psLine ps0 + , psBlkCol = psCol ps0 }) + res <- p + modify (\ps -> ps { psBlkLine = psBlkLine ps0 + , psBlkCol = psBlkCol ps0 }) + return res data Fatality fatal where - Error :: Fatality 'False - Fatal :: Fatality 'True + Error :: Fatality 'False + Fatal :: Fatality 'True deriving instance Show (Fatality fatal) type family FatalCtx fatal a where - FatalCtx 'False a = a ~ () - FatalCtx 'True a = () + FatalCtx 'False a = a ~ () + FatalCtx 'True a = () -- | Raise an error with the given fatality and description. raise :: FatalCtx fatal a => Fatality fatal -> String -> Parser a raise fat msg = do - Context { ctxFile = fp , ctxStack = stk } <- ask - PS { psLine = line, psCol = col } <- get - let fun = case fat of - Error -> dictate . pure - Fatal -> confess . pure - fun (ErrMsg fp stk line col msg) + Context { ctxFile = fp , ctxStack = stk } <- ask + PS { psLine = line, psCol = col } <- get + let fun = case fat of + Error -> dictate . pure + Fatal -> confess . pure + fun (ErrMsg fp stk line col msg) raise' :: Fatality fatal -> String -> Parser () raise' Error = raise Error @@ -609,39 +611,39 @@ data BlockPos = AtLeft | InBlock -- result is returned; otherwise, the parser fails. The newline is not consumed. readToken :: BlockPos -> (s -> Maybe Char -> Maybe (Either r s)) -> s -> Parser (r, String) readToken bpos f s0 = do - case bpos of - AtLeft -> assertAtBlockLeft Fatal "Expected token, but found indented expression" - InBlock -> assertInsideBlock Fatal "Expected token, but found end of indented expression" - let loop :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> Parser (r, String) - loop f' st = do - ps <- get - case psRest ps of - [] | Just (Left res) <- f' st Nothing -> return (res, "") - | otherwise -> empty - '\n' : _ | Just (Left res) <- f' st (Just '\n') -> return (res, "") - c : cs -> case f' st (Just c) of - Nothing -> empty - Just (Left res) -> return (res, "") - Just (Right st') -> do - put (ps { psCol = psCol ps + 1, psRest = cs }) - fmap (c :) <$> loop f' st' - loop f s0 + case bpos of + AtLeft -> assertAtBlockLeft Fatal "Expected token, but found indented expression" + InBlock -> assertInsideBlock Fatal "Expected token, but found end of indented expression" + let loop :: (s -> Maybe Char -> Maybe (Either r s)) -> s -> Parser (r, String) + loop f' st = do + ps <- get + case psRest ps of + [] | Just (Left res) <- f' st Nothing -> return (res, "") + | otherwise -> empty + '\n' : _ | Just (Left res) <- f' st (Just '\n') -> return (res, "") + c : cs -> case f' st (Just c) of + Nothing -> empty + Just (Left res) -> return (res, "") + Just (Right st') -> do + put (ps { psCol = psCol ps + 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, this fails. inlineWhite :: Parser () inlineWhite = do - skipWhiteComment - whenM (not <$> isInsideBlock) empty + skipWhiteComment + whenM (not <$> isInsideBlock) empty -- | Consumes all whitespace and comments (including newlines). Note: this may -- end outside the current block. skipWhiteComment :: Parser () skipWhiteComment = do - inlineSpaces - _ <- many (blockComment >> inlineSpaces) - optional_ lineComment - optional_ (consumeNewline >> skipWhiteComment) + inlineSpaces + _ <- many (blockComment >> inlineSpaces) + optional_ lineComment + optional_ (consumeNewline >> skipWhiteComment) -- | Consumes some inline whitespace. Stops before newlines. inlineSpaces :: Parser () @@ -651,22 +653,22 @@ inlineSpaces = readWhileInline isSpace -- end outside the current block. blockComment :: Parser () blockComment = do - string "{-" -- no need for pKeySym here - let loop = do - readWhileInline (`notElem` "{-") -- "-}" also starts with '-' - asum [string "-}" - ,eof >> raise Error "Unfinished {- -} comment at end of file" - ,blockComment >> loop - ,consumeNewline >> loop] - loop + string "{-" -- no need for pKeySym here + let loop = do + readWhileInline (`notElem` "{-") -- "-}" also starts with '-' + asum [string "-}" + ,eof >> raise Error "Unfinished {- -} comment at end of file" + ,blockComment >> loop + ,consumeNewline >> loop] + loop -- | Consumes a line comment marker and the rest of the line, excluding -- newline. lineComment :: Parser () lineComment = do - -- '--!' is an operator, so we need to parse a whole symbol here. - pKeySym "--" - readWhileInline (const True) + -- '--!' is an operator, so we need to parse a whole symbol here. + pKeySym "--" + readWhileInline (const True) -- | Raises an error if we're not currently at the given column. assertAtBlockLeft :: Fatality fatal -> String -> Parser () @@ -679,55 +681,55 @@ assertInsideBlock fat msg = whenM (not <$> isInsideBlock) $ raise' fat msg -- | Raises an error if we're not currently at EOF. assertEOF :: Fatality fatal -> Parser () assertEOF fat = gets psRest >>= \case - [] -> return () - _ -> raise' fat "Unexpected stuff" + [] -> 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 :: Parser Bool isInsideBlock = do - ps <- get - return $ psLine ps >= psBlkLine ps && psCol ps > psBlkCol ps + ps <- get + return $ psLine ps >= psBlkLine ps && psCol ps > psBlkCol ps -- | 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 :: Parser Bool isAtBlockLeft = do - ps <- get - return $ psLine ps >= psBlkLine ps && psCol ps == psBlkCol ps + ps <- get + return $ psLine ps >= psBlkLine ps && psCol ps == psBlkCol ps -- | Consumes characters while the predicate holds or until (and excluding) -- a newline, whichever comes first. readWhileInline :: (Char -> Bool) -> Parser () readWhileInline p = do - (taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest - modify (\ps -> ps { psCol = psCol ps + length taken - , psRest = rest }) + (taken, rest) <- span (\c -> p c && c /= '\n') <$> gets psRest + modify (\ps -> ps { psCol = psCol ps + length taken + , psRest = rest }) -- | Consumes exactly one newline at the current position. consumeNewline :: Parser () consumeNewline = gets psRest >>= \case - '\n' : rest -> modify (\ps -> ps { psLine = psLine ps + 1 - , psCol = 0 - , psRest = rest }) - _ -> empty + '\n' : rest -> modify (\ps -> ps { psLine = psLine ps + 1 + , psCol = 0 + , psRest = rest }) + _ -> empty -- | Consumes exactly one character, unequal to newline, at the current position. satisfy :: (Char -> Bool) -> Parser Char satisfy p = do - traceM "entering satisfy" - r <- gets psRest - traceM "got rest" - r `seq` return () - traceM "seqd rest" - traceM ("rest is " ++ r) - case r of - c : rest | c /= '\n', p c -> do - modify (\ps -> ps { psCol = psCol ps + 1 - , psRest = rest }) - return c - _ -> empty + traceM "entering satisfy" + r <- gets psRest + traceM "got rest" + r `seq` return () + traceM "seqd rest" + traceM ("rest is " ++ r) + case r of + c : rest | c /= '\n', p c -> do + modify (\ps -> ps { psCol = psCol ps + 1 + , psRest = rest }) + return c + _ -> empty -- | Consumes exactly this character at the current position. Must not be a -- newline. @@ -739,25 +741,25 @@ char c = string [c] string :: String -> Parser () string s | any (== '\n') s = error "Newline in 'string' argument" string s = do - ps <- get - if take (length s) (psRest ps) == s - then put (ps { psCol = psCol ps + length s - , psRest = drop (length s) (psRest ps) }) - else empty + ps <- get + if take (length s) (psRest ps) == s + then put (ps { psCol = psCol ps + length s + , psRest = drop (length s) (psRest ps) }) + else empty lookAhead :: Parser () -> Parser () lookAhead p = do - ps <- get - success <- absolve False (True <$ p) - put ps -- restore state, as if nothing happened - when (not success) empty + ps <- get + success <- absolve False (True <$ p) + put ps -- restore state, as if nothing happened + when (not success) empty notFollowedBy :: Parser () -> Parser () notFollowedBy p = do - ps <- get - success <- absolve True (False <$ p) - put ps -- restore state, as if nothing happened - when (not success) empty + ps <- get + success <- absolve True (False <$ p) + put ps -- restore state, as if nothing happened + when (not success) empty -- | Only succeeds at EOF. eof :: Parser () |