fix more bugs

[fp.git] / src / HM / Parser.hs

diff --git a/src/HM/Parser.hs b/src/HM/Parser.hs
index 54e1e6a..8b5575d 100644 (file)
--- a/src/HM/Parser.hs
+++ b/src/HM/Parser.hs
@@ -11,9 +11,10 @@
 --
 -- Parser for Hindley-Milner terms and types.
 
 --
 -- Parser for Hindley-Milner terms and types.
 

-module HM.Parser 
+module HM.Parser

   ( tRead
   , parseTypedTerm
   ( tRead
   , parseTypedTerm

+  , parseVar

   )  where
 
 import Data.Char (isAsciiLower, isAsciiUpper)
   )  where
 
 import Data.Char (isAsciiLower, isAsciiUpper)


@@ -43,6 +44,9 @@ instance Show Term where
   show (App a (NTTerm (App b c))) = show a ++ " " ++ braced ( show (App b c))
   show (App t r) = show t ++ " " ++ show r
   show (Let x e1 e2) = braced $ "LET " ++ x ++ " = " ++ show e1 ++ " IN " ++ show e2 
   show (App a (NTTerm (App b c))) = show a ++ " " ++ braced ( show (App b c))
   show (App t r) = show t ++ " " ++ show r
   show (Let x e1 e2) = braced $ "LET " ++ x ++ " = " ++ show e1 ++ " IN " ++ show e2 

+  show (Lit (LInt x)) = show x
+  show (Lit (LBool x)) = show x
+  show (Lit (LFunc x)) = show x

 
 instance Show TypedTerm where
   show (NTTerm t) = show t
 
 instance Show TypedTerm where
   show (NTTerm t) = show t


@@ -65,15 +69,17 @@ tRead s = case parseOnly (parseTypedTerm <* endOfInput) (T.pack s) of
 
 parseTerm :: Parser Term
 parseTerm = parseLet <|>
 
 parseTerm :: Parser Term
 parseTerm = parseLet <|>

+            parseLambda <|>

             parseApp <|>
             parseBraces parseTerm <|>
             parseApp <|>
             parseBraces parseTerm <|>

-            parseVar <|>
-            parseLambda
+            parseLit <|>
+            parseVar

 
 parseTermNoApp :: Parser Term
 parseTermNoApp = parseBraces parseTerm <|>
             parseLet <|>
             parseVar <|>
 
 parseTermNoApp :: Parser Term
 parseTermNoApp = parseBraces parseTerm <|>
             parseLet <|>
             parseVar <|>

+            parseLit <|>

             parseLambda
 
 parseTypeAndTerm :: Parser Term -> Parser TypedTerm
             parseLambda
 
 parseTypeAndTerm :: Parser Term -> Parser TypedTerm


@@ -85,25 +91,26 @@ parseTypeAndTerm p = do
 
 
 parseTypedTermNoApp :: Parser TypedTerm
 
 
 parseTypedTermNoApp :: Parser TypedTerm

-parseTypedTermNoApp = parseTypeAndTerm parseTermNoApp <|>
-                      parseBraces parseTypedTerm <|>
+parseTypedTermNoApp = parseBraces parseTypedTerm <|>
+                      parseTypeAndTerm parseTermNoApp <|>

                       (NTTerm <$> parseTermNoApp)
 
 parseTypedTerm :: Parser TypedTerm
 parseTypedTerm = parseTypeAndTerm parseTerm <|>
                       (NTTerm <$> parseTermNoApp)
 
 parseTypedTerm :: Parser TypedTerm
 parseTypedTerm = parseTypeAndTerm parseTerm <|>

-                 parseBraces parseTypedTerm <|>
-                 (NTTerm <$> parseTerm)
+                 (NTTerm <$> parseTerm) <|>
+                 parseBraces parseTypedTerm

 
 parseType :: Parser Type
 
 parseType :: Parser Type

-parseType = parseBraces parseType <|>
+parseType = parseType <|>

             parseTypeFunction <|>
             parsePrimitive <|>
             parseTypeVar
 
 parsePrimitive :: Parser Type
 parsePrimitive = do
             parseTypeFunction <|>
             parsePrimitive <|>
             parseTypeVar
 
 parsePrimitive :: Parser Type
 parsePrimitive = do

-  x <- many1 $ satisfy isAsciiUpper
-  return $! Primitive x
+  x <- satisfy isAsciiUpper
+  xs <- many letter
+  return $! Primitive (x:xs)

 
 parseTypeVar :: Parser Type
 parseTypeVar = do
 
 parseTypeVar :: Parser Type
 parseTypeVar = do


@@ -152,6 +159,25 @@ parseVar = do
   x <- many1 $ satisfy isAsciiLower
   return $! Var x
 
   x <- many1 $ satisfy isAsciiLower
   return $! Var x
 

+parseLit :: Parser Term
+parseLit = do
+  x <- parseLInt <|> parseLBool <|> parseLFun
+  return $! Lit x
+
+parseLFun :: Parser Literal
+parseLFun = 
+  (string "If" >> return (LFunc If))
+
+parseLBool :: Parser Literal
+parseLBool = 
+  (string "True" >> return (LBool True)) <|>
+  (string "False" >> return (LBool False)) 
+
+parseLInt :: Parser Literal
+parseLInt = do
+  x <- decimal
+  return $! LInt x
+

 parseLambda :: Parser Term
 parseLambda = do
   char '\\' <|> char 'λ' <|> char 'L'
 parseLambda :: Parser Term
 parseLambda = do
   char '\\' <|> char 'λ' <|> char 'L'