1 files changed, 133 insertions, 0 deletions
diff --git a/src/Haskell/Parser.hs b/src/Haskell/Parser.hs
new file mode 100644
index 0000000..0f55a63
--- /dev/null
+++ b/src/Haskell/Parser.hs
@@ -0,0 +1,133 @@
+module Haskell.Parser where
+
+import Control.Monad
+import Control.Monad.Identity
+import Haskell.AST
+import Haskell.Parser.Def
+import Text.Parsec
+-- import Text.Parsec.IndentParsec.Combinator
+import Text.Parsec.IndentParsec.Prim
+
+
+type Parser a = GenIndentParsecT HaskellLike String () Identity a
+
+parseAST :: String -> String -> Either ParseError AST
+parseAST fname source = runIdentity $ runGIPT pAST () fname source
+
+pAST :: Parser AST
+pAST = do
+    whiteSpace
+    tops <- pToplevel `sepBy` someNewline
+    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
+
+pDef :: Parser Def
+pDef = do
+    n <- varident
+    args <- many varident
+    reservedOp "="
+    body <- pExpr
+    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)]
+
+pExpr :: Parser Expr
+pExpr = pLam <|> pCase <|> pApp
+  where
+    pSimpleExpr = choice [LitNum <$> integer
+                         ,Ref <$> (identifier <|> try (parens operator))
+                         ,parens pExpr]
+
+    pLam = do
+        reservedOp "\\"
+        args <- many1 varident
+        body <- pExpr
+        return $ Lam args body
+
+    pApp = App <$> pSimpleExpr <*> many pSimpleExpr
+
+    pCase = do
+        reserved "case"
+        n <- varident
+        reserved "of"
+        arms <- bracesBlock (semiSepOrFoldedLines pCaseArm)
+        return $ Case n arms
+
+    pCaseArm = do
+        pat <- pLargePat
+        reservedOp "->"
+        ex <- pExpr
+        return (pat, ex)
+
+pSimplePat :: Parser Pat
+pSimplePat = choice [lexeme (string "_") >> return PatAny
+                    ,PatVar <$> varident
+                    ,typeident >>= \n -> return (PatCon n [])
+                    ,parens pLargePat]
+
+pLargePat :: Parser Pat
+pLargePat = choice [PatCon <$> typeident <*> many pSimplePat
+                   ,pSimplePat]
+
+someNewline :: Parser ()
+someNewline = many (oneOf " \t") >> char '\n' >> whiteSpace