fix more bugs

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

diff --git a/src/HM/Parser.hs b/src/HM/Parser.hs
index 556cbdb..8b5575d 100644 (file)
--- a/src/HM/Parser.hs
+++ b/src/HM/Parser.hs
@@ -11,18 +11,28 @@
 --
 -- Parser for Hindley-Milner terms and types.
 
 --
 -- Parser for Hindley-Milner terms and types.
 

-module HM.Parser 
+module HM.Parser

   ( tRead
   ( tRead

-  , parseTerm
+  , parseTypedTerm
+  , parseVar

   )  where
 
   )  where
 

+import Data.Char (isAsciiLower, isAsciiUpper)

 import Data.Text as T hiding (map)
 import Data.Attoparsec.Text
 import Control.Applicative
 
 import HM.Term
 import Data.Text as T hiding (map)
 import Data.Attoparsec.Text
 import Control.Applicative
 
 import HM.Term

-import qualified Lambda.Parser.Fancy as Lambda
-import qualified Lambda.Term as Lambda
+
+-- $setup
+-- >>> import Test.QuickCheck
+-- >>> import Test.HM.Term
+
+-- | 
+-- >>> print $ Lam "x" (Var "x")
+-- (λx.x)
+
+

 
 braced :: String -> String
 braced t = "(" ++ t ++ ")"
 
 braced :: String -> String
 braced t = "(" ++ t ++ ")"


@@ -31,13 +41,17 @@ instance Show Term where
   show (Var x) = x
   show (Lam x (NTTerm (Lam y t))) = show (Lam (x ++ " " ++ y) t)
   show (Lam x t) = braced $ "λ" ++ x ++ "." ++ show t 
   show (Var x) = x
   show (Lam x (NTTerm (Lam y t))) = show (Lam (x ++ " " ++ y) t)
   show (Lam x t) = braced $ "λ" ++ x ++ "." ++ show t 

-  show (App a (NTTerm (App b c))) = show a ++ " " ++ (braced $ show (App b c))
+  show (App a (NTTerm (App b c))) = show a ++ " " ++ braced ( show (App b c))

   show (App t r) = show t ++ " " ++ show r
   show (App t r) = show t ++ " " ++ show r

-  show (Let x e1 e2) = braced $ "let " ++ x ++ " = " ++ show e1 ++ " in " ++ show e2 
+  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

-  show (TTerm t tp) = braced $ show t ++ " :: " ++ show tp 
+  show (TTerm (Var x) tp) = x ++ " :: " ++ show tp 
+  show (TTerm t tp) = braced (show t) ++ " :: " ++ show tp 

 
 instance Show Type where
   show (Primitive t) = t
 
 instance Show Type where
   show (Primitive t) = t


@@ -48,36 +62,146 @@ instance Show TypeScheme where
   show (TScheme t) = show t
   show (TSForAll x t) = braced $ "∀" ++ x ++ ": " ++ show t
 
   show (TScheme t) = show t
   show (TSForAll x t) = braced $ "∀" ++ x ++ ": " ++ show t
 

-tRead :: String -> Term
-tRead = undefined
+tRead :: String -> TypedTerm
+tRead s = case parseOnly (parseTypedTerm <* endOfInput) (T.pack s) of
+    (Right t) -> t
+    (Left e) -> error e

 
 

-parseTerm :: Parser TypedTerm
+parseTerm :: Parser Term

 parseTerm = parseLet <|>
 parseTerm = parseLet <|>

-            (lambdaToHM <$> Lambda.parseTerm)
+            parseLambda <|>
+            parseApp <|>
+            parseBraces parseTerm <|>
+            parseLit <|>
+            parseVar

 
 

-parseLet :: Parser TypedTerm
-parseLet = do
+parseTermNoApp :: Parser Term
+parseTermNoApp = parseBraces parseTerm <|>
+            parseLet <|>
+            parseVar <|>
+            parseLit <|>
+            parseLambda
+
+parseTypeAndTerm :: Parser Term -> Parser TypedTerm
+parseTypeAndTerm p = do
+  term <- p
+  string " :: "
+  tp <- parseTypeScheme
+  return $! TTerm term tp
+
+
+parseTypedTermNoApp :: Parser TypedTerm
+parseTypedTermNoApp = parseBraces parseTypedTerm <|>
+                      parseTypeAndTerm parseTermNoApp <|>
+                      (NTTerm <$> parseTermNoApp)
+
+parseTypedTerm :: Parser TypedTerm
+parseTypedTerm = parseTypeAndTerm parseTerm <|>
+                 (NTTerm <$> parseTerm) <|>
+                 parseBraces parseTypedTerm
+
+parseType :: Parser Type
+parseType = parseType <|>
+            parseTypeFunction <|>
+            parsePrimitive <|>
+            parseTypeVar
+
+parsePrimitive :: Parser Type
+parsePrimitive = do
+  x <- satisfy isAsciiUpper
+  xs <- many letter
+  return $! Primitive (x:xs)
+
+parseTypeVar :: Parser Type
+parseTypeVar = do
+  x <- many1 $ satisfy isAsciiLower 
+  return $! TypeVar x
+
+parseTypeFunction :: Parser Type
+parseTypeFunction = do
+  a <- parseBraces parseType <|> parsePrimitive <|> parseTypeVar
+  string " -> "
+  b <- parseType
+  return $! TypeFunction a b
+
+parseTypeScheme :: Parser TypeScheme
+parseTypeScheme = parseBraces parseTypeScheme <|>
+                  parseForAll <|>
+                  (TScheme <$> parseType)
+
+parseForAll :: Parser TypeScheme
+parseForAll = do
+  string "FORALL "
+  (TypeVar x) <- parseTypeVar
+  string ": " 
+  t <- parseTypeScheme
+  return $! TSForAll x t
+
+parseBraces :: Parser a -> Parser a
+parseBraces p = do

   char '('
   char '('

-  string "let "
-  (Lambda.Var x) <- Lambda.parseVar
-  string " = "
-  e1 <- lambdaToHM <$> Lambda.parseTerm
-  string " in "
-  e2 <- lambdaToHM <$> Lambda.parseTerm
+  t <- p

   char ')'
   char ')'

-  return . NTTerm $ Let x e1 e2
+  return t 
+
+parseLet :: Parser Term
+parseLet = do
+  string "LET "
+  (Var x) <- parseVar
+  string " = "
+  e1 <- parseTypedTerm
+  string " IN "
+  e2 <- parseTypedTerm
+  return $! Let x e1 e2
+
+parseVar :: Parser Term
+parseVar = do
+  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'
+  vars <- sepBy1 parseVar (char ' ')
+  char '.'
+  t <- parseTypedTerm
+  let (NTTerm l) = createLambda vars t
+  return $! l
+
+parseApp :: Parser Term
+parseApp = do
+  aps <- sepBy1 parseTypedTermNoApp (char ' ')
+  createApp aps
+
+createLambda :: [Term] -> TypedTerm -> TypedTerm
+createLambda (Var x : vs) t = NTTerm . Lam x $ createLambda vs t
+createLambda [] t = t
+createLambda _ _ = error "createLambda failed"
+
+createApp :: [TypedTerm] -> Parser Term
+createApp [t,ts] = return $ App t ts
+createApp (t:ts:tss) = createApp (NTTerm (App t ts) : tss)
+createApp _ = fail "not App"

 
 

-lambdaToHM :: Lambda.Term -> TypedTerm
-lambdaToHM (Lambda.Var x) = NTTerm $ Var x
-lambdaToHM (Lambda.App t u) = NTTerm $ App (lambdaToHM t) (lambdaToHM u)
-lambdaToHM (Lambda.Lambda x t) = NTTerm $ Lam x (lambdaToHM t)

 
 -- |
 -- TODO prop> t == tRead (show (t :: Term))
 
 -- |
 -- TODO prop> t == tRead (show (t :: Term))

-
-{-
-tRead :: String -> Term
-tRead s = case parseOnly (parseTerm <* endOfInput) (T.pack s) of
-    (Right t) -> t
-    (Left e) -> error e
--}