HM type inference

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

diff --git a/src/HM/Parser.hs b/src/HM/Parser.hs
index f02a7cc..54e1e6a 100644 (file)
--- a/src/HM/Parser.hs
+++ b/src/HM/Parser.hs
@@ -13,7 +13,7 @@
 
 module HM.Parser 
   ( tRead
 
 module HM.Parser 
   ( tRead

-  , parseTerm
+  , parseTypedTerm

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


@@ -23,6 +23,16 @@ import Control.Applicative
 
 import HM.Term
 
 
 import HM.Term
 

+-- $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 ++ ")"
 


@@ -36,7 +46,8 @@ instance Show Term where
 
 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


@@ -55,42 +66,39 @@ tRead s = case parseOnly (parseTypedTerm <* endOfInput) (T.pack s) of
 parseTerm :: Parser Term
 parseTerm = parseLet <|>
             parseApp <|>
 parseTerm :: Parser Term
 parseTerm = parseLet <|>
             parseApp <|>

+            parseBraces parseTerm <|>

             parseVar <|>
             parseLambda
 
             parseVar <|>
             parseLambda
 

-parseTermNA :: Parser Term
-parseTermNA = parseLet <|>
+parseTermNoApp :: Parser Term
+parseTermNoApp = parseBraces parseTerm <|>
+            parseLet <|>

             parseVar <|>
             parseLambda
 
             parseVar <|>
             parseLambda
 

-parseTypeAndTermNA :: Parser TypedTerm
-parseTypeAndTermNA = do
-  term <- parseTermNA
+parseTypeAndTerm :: Parser Term -> Parser TypedTerm
+parseTypeAndTerm p = do
+  term <- p

   string " :: "
   tp <- parseTypeScheme
   return $! TTerm term tp
 
   string " :: "
   tp <- parseTypeScheme
   return $! TTerm term tp
 

-parseTypeAndTerm :: Parser TypedTerm
-parseTypeAndTerm = do
-  term <- parseTerm
-  string " :: "
-  tp <- parseTypeScheme
-  return $! TTerm term tp

 
 

-parseTypedTermNA :: Parser TypedTerm
-parseTypedTermNA = parseBraces <|>
-                   parseTypeAndTermNA <|>
-                   (NTTerm <$> parseTerm)
+parseTypedTermNoApp :: Parser TypedTerm
+parseTypedTermNoApp = parseTypeAndTerm parseTermNoApp <|>
+                      parseBraces parseTypedTerm <|>
+                      (NTTerm <$> parseTermNoApp)

 
 parseTypedTerm :: Parser TypedTerm
 
 parseTypedTerm :: Parser TypedTerm

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

 
 parseType :: Parser Type
 
 parseType :: Parser Type

-parseType = parsePrimitive <|>
-            parseTypeVar <|>
-            parseTypeFunction
+parseType = parseBraces parseType <|>
+            parseTypeFunction <|>
+            parsePrimitive <|>
+            parseTypeVar

 
 parsePrimitive :: Parser Type
 parsePrimitive = do
 
 parsePrimitive :: Parser Type
 parsePrimitive = do


@@ -99,32 +107,33 @@ parsePrimitive = do
 
 parseTypeVar :: Parser Type
 parseTypeVar = do
 
 parseTypeVar :: Parser Type
 parseTypeVar = do

-  x <- many1 $ satisfy isAsciiLower
+  x <- many1 $ satisfy isAsciiLower 

   return $! TypeVar x
 
 parseTypeFunction :: Parser Type
 parseTypeFunction = do
   return $! TypeVar x
 
 parseTypeFunction :: Parser Type
 parseTypeFunction = do

-  a <- parseType
+  a <- parseBraces parseType <|> parsePrimitive <|> parseTypeVar

   string " -> "
   b <- parseType
   return $! TypeFunction a b
 
 parseTypeScheme :: Parser TypeScheme
   string " -> "
   b <- parseType
   return $! TypeFunction a b
 
 parseTypeScheme :: Parser TypeScheme

-parseTypeScheme = parseForAll <|>
+parseTypeScheme = parseBraces parseTypeScheme <|>
+                  parseForAll <|>

                   (TScheme <$> parseType)
 
 parseForAll :: Parser TypeScheme
 parseForAll = do
   string "FORALL "
   (TypeVar x) <- parseTypeVar
                   (TScheme <$> parseType)
 
 parseForAll :: Parser TypeScheme
 parseForAll = do
   string "FORALL "
   (TypeVar x) <- parseTypeVar

-  string "."
+  string ": " 

   t <- parseTypeScheme
   return $! TSForAll x t
 
   t <- parseTypeScheme
   return $! TSForAll x t
 

-parseBraces :: Parser TypedTerm
-parseBraces = do
+parseBraces :: Parser a -> Parser a
+parseBraces p = do

   char '('
   char '('

-  t <- parseTypedTerm
+  t <- p

   char ')'
   return t 
 
   char ')'
   return t 
 


@@ -154,18 +163,18 @@ parseLambda = do
 
 parseApp :: Parser Term
 parseApp = do
 
 parseApp :: Parser Term
 parseApp = do

-  aps <- sepBy1 parseTypedTermNA (char ' ')
-  return $! createApp aps
+  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"
 
 
 createLambda :: [Term] -> TypedTerm -> TypedTerm
 createLambda (Var x : vs) t = NTTerm . Lam x $ createLambda vs t
 createLambda [] t = t
 createLambda _ _ = error "createLambda failed"
 

-createApp :: [TypedTerm] -> Term
-createApp [t,ts] = App t ts
+createApp :: [TypedTerm] -> Parser Term
+createApp [t,ts] = return $ App t ts

 createApp (t:ts:tss) = createApp (NTTerm (App t ts) : tss)
 createApp (t:ts:tss) = createApp (NTTerm (App t ts) : tss)

-createApp [] = error "empty createApp"
+createApp _ = fail "not App"

 
 
 -- |
 
 
 -- |