some work on HM interpreter

diff --git a/Logic.hm b/Logic.hm
new file mode 100644 (file)
index 0000000..b8ec073
--- /dev/null
+++ b/Logic.hm
@@ -0,0 +1,3 @@
+not=(\x.If x False True) :: Bool -> Bool
+
+not False

diff --git a/fp.cabal b/fp.cabal
index 31046b0..7a1dd3f 100644 (file)
--- a/fp.cabal
+++ b/fp.cabal
@@ -21,7 +21,7 @@ library
                    Lambda.Parser.Simple
                    HM
                    HM.Parser
                    Lambda.Parser.Simple
                    HM
                    HM.Parser

-  other-modules:   Lambda.Term
+                   Lambda.Term

                    HM.Term
   build-depends:       base >=4.7 && <5
                      , text >=1.2 && <1.3
                    HM.Term
   build-depends:       base >=4.7 && <5
                      , text >=1.2 && <1.3

diff --git a/src/HM.hs b/src/HM.hs
index 8f6df2f..e643938 100644 (file)
--- a/src/HM.hs
+++ b/src/HM.hs
@@ -91,13 +91,20 @@ unify (TypeFunction a b) (TypeFunction a' b') = do
 unify (Primitive a) (Primitive b) | a == b = return idSub
 unify a b = fail $ "cannot unify " ++ show a ++ " with " ++ show b
 
 unify (Primitive a) (Primitive b) | a == b = return idSub
 unify a b = fail $ "cannot unify " ++ show a ++ " with " ++ show b
 

+tiLit :: Literal -> TI (Substitution, Type)
+tiLit (LBool _) = return (idSub, Primitive "Bool")
+tiLit (LInt _) = return (idSub, Primitive "Integer")
+tiLit (LFunc If) = do
+  a <- newVar
+  return (idSub, Primitive "Bool" `TypeFunction` (a `TypeFunction` (a `TypeFunction` a)))
+

 ti :: TypeEnv -> TypedTerm -> TI (Substitution, Type)
 ti :: TypeEnv -> TypedTerm -> TI (Substitution, Type)

---ti _ (TTerm (Var v) (TScheme t@(Primitive _))) = return (idSub, t)

 ti e (TTerm tr sch) = do
   (s, t) <- ti e (NTTerm tr)
   sch' <- instantiate sch
   s' <- unify t sch'
   return (s', substituteT s' sch')
 ti e (TTerm tr sch) = do
   (s, t) <- ti e (NTTerm tr)
   sch' <- instantiate sch
   s' <- unify t sch'
   return (s', substituteT s' sch')

+ti _ (NTTerm (Lit l)) = tiLit l

 ti e (NTTerm (Var v)) = case Map.lookup v e of
   Nothing -> fail $ "unbound variable: " ++ v
   Just sigma -> do
 ti e (NTTerm (Var v)) = case Map.lookup v e of
   Nothing -> fail $ "unbound variable: " ++ v
   Just sigma -> do

diff --git a/src/HM/Interpreter.hs b/src/HM/Interpreter.hs
new file mode 100644 (file)
index 0000000..90f5595
--- /dev/null
+++ b/src/HM/Interpreter.hs
@@ -0,0 +1,66 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+
+module HM.Interpreter (
+    interpret
+  ) where
+
+import Data.Text as T (Text, pack)
+import qualified Data.Text.IO as T
+import Data.Attoparsec.Text
+import qualified Data.Map as M
+import Control.Applicative
+import Control.Monad
+import System.Environment
+
+import HM
+import HM.Term
+import HM.Parser
+
+import qualified Lambda as L
+
+data Definition = Definition String TypedTerm
+
+dictionary :: [Definition] -> M.Map VarName TypedTerm
+dictionary = M.fromList . map (\ (Definition s t) -> (s, t))
+
+parseDefinition :: Parser Definition
+parseDefinition = do
+  name <- parseVar
+  char '='
+  t <- parseTypedTerm
+  return $! Definition name t
+
+parseImport :: Parser String
+parseImport = do
+  string (T.pack "import ")
+  many1 letter
+
+parseFile :: Text -> ([FilePath], [Definition], [Term])
+parseFile txt = case cnt of
+    (Right t) -> t
+    (Left e) -> error e
+  where cnt = parseOnly (parserF <* endOfInput) txt
+        parserF = do
+          imports <- many (parseImport <* char '\n')
+          defs <- many (parseDefinition <* char '\n')
+          terms <- many (parseTypedTerm <* char '\n')
+          return (imports, defs, terms)
+
+printEval :: (Term -> Term) -> Term -> IO ()
+printEval def t = do
+  putStrLn $ show t ++ ":"
+  putStrLn $ "  " ++ show (reduce $ def t)
+  putStrLn ""
+
+makeDefTerm :: [Definition] -> Term -> Term
+makeDefTerm (Definition name dTerm : ds) t = App (Lambda name (makeDefTerm ds t)) dTerm
+makeDefTerm [] t = t
+
+interpret :: FilePath -> IO ()
+interpret filename = do
+  (imports, defs, terms) <- parseFile <$> T.readFile filename
+  importDefs <- forM imports $ \ file ->  do
+        (_, idefs, _) <- parseFile <$> T.readFile (file ++ ".hm")
+        return idefs
+  let defT = makeDefTerm $ concat importDefs ++ defs
+  mapM_ (printEval defT) terms

diff --git a/src/HM/Parser.hs b/src/HM/Parser.hs
index 54e1e6a..24ade14 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


@@ -102,8 +108,9 @@ parseType = parseBraces parseType <|>
 
 parsePrimitive :: Parser Type
 parsePrimitive = do
 
 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'

diff --git a/src/HM/Term.hs b/src/HM/Term.hs
index cf4cf36..fc705af 100644 (file)
--- a/src/HM/Term.hs
+++ b/src/HM/Term.hs
@@ -10,13 +10,15 @@
 
 module HM.Term
   ( -- * Types
 
 module HM.Term
   ( -- * Types

-    VarName
+    Literal(..)
+  , VarName

   , TypeVarName
   , TypeName
   , Term(..)
   , TypedTerm(..)
   , Type(..)
   , TypeScheme(..)
   , TypeVarName
   , TypeName
   , Term(..)
   , TypedTerm(..)
   , Type(..)
   , TypeScheme(..)

+  , PrimOp(..)

   ) where
 
 type VarName = String
   ) where
 
 type VarName = String


@@ -26,5 +28,8 @@ type TypeName = String
 data Type = Primitive TypeName | TypeVar TypeVarName | TypeFunction Type Type deriving (Eq)
 data TypeScheme = TScheme Type | TSForAll TypeVarName TypeScheme deriving (Eq)
 
 data Type = Primitive TypeName | TypeVar TypeVarName | TypeFunction Type Type deriving (Eq)
 data TypeScheme = TScheme Type | TSForAll TypeVarName TypeScheme deriving (Eq)
 

-data Term = Var VarName | Lam VarName TypedTerm | App TypedTerm TypedTerm | Let VarName TypedTerm TypedTerm
+data Term = Var VarName | Lam VarName TypedTerm | App TypedTerm TypedTerm | Let VarName TypedTerm TypedTerm | Lit Literal

 data TypedTerm = NTTerm Term | TTerm Term TypeScheme
 data TypedTerm = NTTerm Term | TTerm Term TypeScheme

+data Literal = LInt Integer | LBool Bool | LFunc PrimOp deriving (Eq)
+
+data PrimOp = If deriving (Eq, Show)

diff --git a/src/HM/Test.hs b/src/HM/Test.hs
new file mode 100644 (file)
index 0000000..bcdbd65
--- /dev/null
+++ b/src/HM/Test.hs
@@ -0,0 +1,13 @@
+module HM.Test where
+
+import HM
+import HM.Parser
+
+test x = do
+  print $ tRead x
+  print . algW $ tRead x
+
+x1 = "x :: T"
+x2 = "\\x.x :: T"
+x3 = "\\x.x"
+x4 = "\\x.\\y.z"

diff --git a/src/Lambda/Interpreter.hs b/src/Lambda/Interpreter.hs
new file mode 100644 (file)
index 0000000..a187605
--- /dev/null
+++ b/src/Lambda/Interpreter.hs
@@ -0,0 +1,63 @@
+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
+
+module Lambda.Interpreter (
+    interpret
+  ) where
+
+import Data.Text as T (Text, pack)
+import qualified Data.Text.IO as T
+import Data.Attoparsec.Text
+import qualified Data.Map as M
+import Control.Applicative
+import Control.Monad
+import System.Environment
+
+import Lambda
+import Lambda.Parser.Fancy
+
+data Definition = Definition String Term
+
+dictionary :: [Definition] -> M.Map String Term
+dictionary = M.fromList . map (\ (Definition s t) -> (s, t))
+
+parseDefinition :: Parser Definition
+parseDefinition = do
+  name <- many1 letter
+  char '='
+  t <- parseTerm
+  return $! Definition name t
+
+parseImport :: Parser String
+parseImport = do
+  string (T.pack "import ")
+  many1 letter
+
+parseFile :: Text -> ([FilePath], [Definition], [Term])
+parseFile txt = case cnt of
+    (Right t) -> t
+    (Left e) -> error e
+  where cnt = parseOnly (parserF <* endOfInput) txt
+        parserF = do
+          imports <- many (parseImport <* char '\n')
+          defs <- many (parseDefinition <* char '\n')
+          terms <- many (parseTerm <* char '\n')
+          return (imports, defs, terms)
+
+printEval :: (Term -> Term) -> Term -> IO ()
+printEval def t = do
+  putStrLn $ show t ++ ":"
+  putStrLn $ "  " ++ show (reduce $ def t)
+  putStrLn ""
+
+makeDefTerm :: [Definition] -> Term -> Term
+makeDefTerm (Definition name dTerm : ds) t = App (Lambda name (makeDefTerm ds t)) dTerm
+makeDefTerm [] t = t
+
+interpret :: FilePath -> IO ()
+interpret filename = do
+  (imports, defs, terms) <- parseFile <$> T.readFile filename
+  importDefs <- forM imports $ \ file ->  do
+        (_, idefs, _) <- parseFile <$> T.readFile (file ++ ".lc")
+        return idefs
+  let defT = makeDefTerm $ concat importDefs ++ defs
+  mapM_ (printEval defT) terms

diff --git a/src/Lambda/Parser/Fancy.hs b/src/Lambda/Parser/Fancy.hs
index 3ad5728..f7a523d 100644 (file)
--- a/src/Lambda/Parser/Fancy.hs
+++ b/src/Lambda/Parser/Fancy.hs
@@ -57,7 +57,7 @@ tRead s = case parseOnly (parseTerm <* endOfInput) (T.pack s) of
 
 parseVar :: Parser Term
 parseVar = do
 
 parseVar :: Parser Term
 parseVar = do

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

   return $! Var x
 
 parseLambda :: Parser Term
   return $! Var x
 
 parseLambda :: Parser Term

diff --git a/src/Main.hs b/src/Main.hs
index 4ddfe2d..8253f88 100644 (file)
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,62 +1,10 @@
-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
-

 module Main where
 
 module Main where
 

-import Data.Text as T (Text, pack)
-import qualified Data.Text.IO as T
-import Data.Attoparsec.Text
-import qualified Data.Map as M
-import Control.Applicative
-import Control.Monad

 import System.Environment
 
 import System.Environment
 

-import Lambda
-import Lambda.Parser.Fancy
-
-data Definition = Definition String Term
-
-dictionary :: [Definition] -> M.Map String Term
-dictionary = M.fromList . map (\ (Definition s t) -> (s, t))
-
-parseDefinition :: Parser Definition
-parseDefinition = do
-  name <- many1 letter
-  char '='
-  t <- parseTerm
-  return $! Definition name t
-
-parseImport :: Parser String
-parseImport = do
-  string (T.pack "import ")
-  many1 letter
-
-parseFile :: Text -> ([FilePath], [Definition], [Term])
-parseFile txt = case cnt of
-    (Right t) -> t
-    (Left e) -> error e
-  where cnt = parseOnly (parserF <* endOfInput) txt
-        parserF = do
-          imports <- many (parseImport <* char '\n')
-          defs <- many (parseDefinition <* char '\n')
-          terms <- many (parseTerm <* char '\n')
-          return (imports, defs, terms)
-
-printEval :: (Term -> Term) -> Term -> IO ()
-printEval def t = do
-  putStrLn $ show t ++ ":"
-  putStrLn $ "  " ++ show (reduce $ def t)
-  putStrLn ""
-
-makeDefTerm :: [Definition] -> Term -> Term
-makeDefTerm (Definition name dTerm : ds) t = App (Lambda name (makeDefTerm ds t)) dTerm
-makeDefTerm [] t = t
+import Lambda.Interpreter as L

 
 main :: IO ()
 main = do
   [filename] <- getArgs
 
 main :: IO ()
 main = do
   [filename] <- getArgs

-  (imports, defs, terms) <- parseFile <$> T.readFile filename
-  importDefs <- forM imports $ \ file ->  do
-        (_, idefs, _) <- parseFile <$> T.readFile (file ++ ".lc")
-        return idefs
-  let defT = makeDefTerm $ concat importDefs ++ defs
-  mapM_ (printEval defT) terms
+  L.interpret filename