diff options
Diffstat (limited to 'src/Haskell/Parser.hs')
-rw-r--r-- | src/Haskell/Parser.hs | 182 |
1 files changed, 92 insertions, 90 deletions
diff --git a/src/Haskell/Parser.hs b/src/Haskell/Parser.hs index e7b9535..dcee39e 100644 --- a/src/Haskell/Parser.hs +++ b/src/Haskell/Parser.hs @@ -1,133 +1,135 @@ module Haskell.Parser where import Control.Monad -import Control.Monad.Identity +import Data.Char import Haskell.AST -import Haskell.Parser.Def import Text.Parsec --- import Text.Parsec.IndentParsec.Combinator -import Text.Parsec.IndentParsec.Prim +import Text.Parsec.String -type Parser a = GenIndentParsecT HaskellLike String () Identity a - parseAST :: String -> String -> Either ParseError AST -parseAST fname source = runIdentity $ runGIPT pAST () fname source +parseAST fname source = parse pAST fname source pAST :: Parser AST pAST = do - whiteSpace - tops <- pToplevel `sepBy` someNewline + whitespace + tops <- many pToplevel eof return $ AST tops pToplevel :: Parser Toplevel -pToplevel = choice [TopClass <$> pClass - ,TopInst <$> pInst - ,TopData <$> pData - ,TopDecl <$> pDecl - ,TopDef <$> pDef] - -pData :: Parser Data -pData = do - reserved "data" - n <- typeident - vars <- many varident - ty <- choice [do reservedOp "=" - pConstr `sepBy` reservedOp "|" - ,return []] - return $ Data n vars ty - where - pConstr = liftM2 (,) typeident (many pType) - -pClass :: Parser Class -pClass = do - reserved "class" - n <- typeident - vars <- many varident - reserved "where" - decls <- bracesBlock (semiSepOrFoldedLines pDecl) - return $ Class n vars decls - -pInst :: Parser Inst -pInst = do - reserved "instance" - (n, ty) <- pType >>= \case - TyRef n [ty] -> return (n, ty) - _ -> fail "invalid instance head" - reserved "where" - decls <- bracesBlock (semiSepOrFoldedLines pDef) - return $ Inst n ty decls - -pDecl :: Parser Decl -pDecl = do - n <- try (varident <* reservedOp "::") - ty <- pType - return $ Decl n ty +pToplevel = TopDef <$> pDef pDef :: Parser Def pDef = do - n <- varident - args <- many varident - reservedOp "=" - body <- pExpr + n <- pVariable + args <- many pNameV + symbolO "=" + ex <- pExpr + symbolO ";" case args of - [] -> return $ Def n body - _ -> return $ Def n (Lam args body) - -pType :: Parser Type -pType = foldr1 TyFun <$> pSimpleType `sepBy` reservedOp "->" - where - pSimpleType :: Parser Type - pSimpleType = choice [do n <- typeident - args <- many pAtomicType - return (TyRef n args) - ,pAtomicType] - - pAtomicType :: Parser Type - pAtomicType = choice [typeident >>= \n -> return (TyRef n []) - ,TyVar <$> varident - ,parens (pType `sepBy` comma) >>= \case - [ty] -> return ty - tys -> return (TyTup tys)] + [] -> return $ Def n ex + _ -> return $ Def n (Lam args ex) pExpr :: Parser Expr pExpr = pLam <|> pCase <|> pApp where - pSimpleExpr = choice [Num <$> integer - ,Ref <$> (identifier <|> try (parens operator)) - ,parens pExpr] + pSimpleExpr = choice [Num <$> pNum + ,Ref <$> pVariable + ,parens (pExpr `sepBy` symbolO ",") >>= \case + [ex] -> return ex + exs -> return $ Tup exs] pLam = do - reservedOp "\\" - args <- many1 varident + symbolO "\\" + args <- many1 pNameV body <- pExpr return $ Lam args body - pApp = App <$> pSimpleExpr <*> many pSimpleExpr + pApp = many1 pSimpleExpr >>= \case + [] -> undefined + [e] -> return e + (e:es) -> return $ App e es pCase = do - reserved "case" + symbolW "case" e <- pExpr - reserved "of" - arms <- bracesBlock (semiSepOrFoldedLines pCaseArm) + symbolW "of" + arms <- braces (pCaseArm `sepBy` symbolO ";") return $ Case e arms pCaseArm = do pat <- pLargePat - reservedOp "->" + symbolO "->" ex <- pExpr return (pat, ex) pSimplePat :: Parser Pat -pSimplePat = choice [lexeme (string "_") >> return PatAny - ,PatVar <$> varident - ,typeident >>= \n -> return (PatCon n []) - ,parens pLargePat] +pSimplePat = choice [symbolW "_" >> return PatAny + ,PatVar <$> pNameV + ,pNameT >>= \n -> return (PatCon n []) + ,parens (pLargePat `sepBy` symbolO ",") >>= \case + [pat] -> return pat + pats -> return $ PatTup pats] pLargePat :: Parser Pat -pLargePat = choice [PatCon <$> typeident <*> many pSimplePat +pLargePat = choice [PatCon <$> pNameT <*> many pSimplePat ,pSimplePat] -someNewline :: Parser () -someNewline = many (oneOf " \t") >> char '\n' >> whiteSpace +pNum :: Parser Integer +pNum = (char '-' >> (negate <$> pPositive)) <|> pPositive + where pPositive = read <$> many1 digit + +pVariable :: Parser Name +pVariable = pName <|> try (parens pOperator) + +pName :: Parser Name +pName = notReserved $ liftM2 (:) (satisfy isAlpha) pNameRest + +pNameV :: Parser Name +pNameV = notReserved $ liftM2 (:) (satisfy isLower) pNameRest + +pNameT :: Parser Name +pNameT = notReserved $ liftM2 (:) (satisfy isUpper) pNameRest + +pNameRest :: Parser Name +pNameRest = many (satisfy $ \d -> isAlphaNum d || d == '_') <* aheadW + +notReserved :: Parser Name -> Parser Name +notReserved p = + try $ p >>= \n -> + if n `elem` reservedWords then unexpected "reserved word" else return n + +pOperator :: Parser String +pOperator = many1 (oneOf ":!#$%&*+./<=>?@\\^|-~") <* aheadO + +parens :: Parser a -> Parser a +parens = between (symbolBare "(") (symbolBare ")") + +braces :: Parser a -> Parser a +braces = between (symbolBare "{") (symbolBare "}") + +symbolW :: String -> Parser () +symbolW s = string s >> aheadW + +symbolO :: String -> Parser () +symbolO s = string s >> aheadO + +symbolBare :: String -> Parser () +symbolBare s = string s >> whitespace + +aheadW :: Parser () +aheadW = do + void (lookAhead (space <|> satisfy (\d -> not (isAlphaNum d) && d /= '_'))) <|> eof + whitespace + +aheadO :: Parser () +aheadO = do + void (lookAhead (space <|> alphaNum <|> oneOf ")};")) <|> eof + whitespace + +whitespace :: Parser () +whitespace = void $ many space + +reservedWords :: [String] +reservedWords = ["case", "of", "class", "instance", "where", "let", "in"] |