diff options
Diffstat (limited to 'src/Haskell/SimpleParser.hs')
-rw-r--r-- | src/Haskell/SimpleParser.hs | 124 |
1 files changed, 124 insertions, 0 deletions
diff --git a/src/Haskell/SimpleParser.hs b/src/Haskell/SimpleParser.hs new file mode 100644 index 0000000..26308de --- /dev/null +++ b/src/Haskell/SimpleParser.hs @@ -0,0 +1,124 @@ +module Haskell.SimpleParser where + +import Control.Monad +import Data.Char +import Haskell.AST +import Text.Parsec +import Text.Parsec.String + + +parseAST :: String -> String -> Either ParseError AST +parseAST fname source = parse pAST fname source + +pAST :: Parser AST +pAST = do + whitespace + tops <- many pToplevel + eof + return $ AST tops + +pToplevel :: Parser Toplevel +pToplevel = TopDef <$> pDef + +pDef :: Parser Def +pDef = do + n <- pNameV + args <- many pNameV + symbolO "=" + ex <- pExpr + symbolO ";" + case args of + [] -> return $ Def n ex + _ -> return $ Def n (Lam args ex) + +pExpr :: Parser Expr +pExpr = pLam <|> pCase <|> pApp + where + pSimpleExpr = choice [LitNum <$> pNum + ,Ref <$> (pName <|> try (parens pOperator)) + ,parens (pExpr `sepBy` symbolO ",") >>= \case + [ex] -> return ex + exs -> return $ Tup exs] + + pLam = do + symbolO "\\" + args <- many1 pNameV + body <- pExpr + return $ Lam args body + + pApp = many1 pSimpleExpr >>= \case + [] -> undefined + [e] -> return e + (e:es) -> return $ App e es + + pCase = do + symbolW "case" + n <- pNameV + symbolW "of" + arms <- braces (pCaseArm `sepBy` symbolO ";") + return $ Case n arms + + pCaseArm = do + pat <- pLargePat + symbolO "->" + ex <- pExpr + return (pat, ex) + +pSimplePat :: Parser Pat +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 <$> pNameT <*> many pSimplePat + ,pSimplePat] + +pNum :: Parser Integer +pNum = (char '-' >> (negate <$> pPositive)) <|> pPositive + where pPositive = read <$> many1 digit + +pName :: Parser Name +pName = liftM2 (:) (satisfy isAlpha) pNameRest + +pNameV :: Parser Name +pNameV = liftM2 (:) (satisfy isLower) pNameRest + +pNameT :: Parser Name +pNameT = liftM2 (:) (satisfy isUpper) pNameRest + +pNameRest :: Parser Name +pNameRest = many (satisfy $ \d -> isAlphaNum d || d == '_') <* aheadW + +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 |