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"]