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