From: TomᚠMusil Date: Tue, 1 Sep 2015 23:30:46 +0000 (+0200) Subject: some work on HM interpreter X-Git-Url: http://git.tomasm.cz/fp.git/commitdiff_plain/763aa13445f67ffe289fe6f3186dd269a909d8a5?ds=sidebyside some work on HM interpreter --- diff --git a/Logic.hm b/Logic.hm new file mode 100644 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 --- a/fp.cabal +++ b/fp.cabal @@ -21,7 +21,7 @@ library 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 diff --git a/src/HM.hs b/src/HM.hs index 8f6df2f..e643938 100644 --- 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 +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 _ (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 _ (NTTerm (Lit l)) = tiLit l 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 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 --- a/src/HM/Parser.hs +++ b/src/HM/Parser.hs @@ -11,9 +11,10 @@ -- -- Parser for Hindley-Milner terms and types. -module HM.Parser +module HM.Parser ( tRead , parseTypedTerm + , parseVar ) 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 (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 @@ -65,15 +69,17 @@ tRead s = case parseOnly (parseTypedTerm <* endOfInput) (T.pack s) of parseTerm :: Parser Term parseTerm = parseLet <|> + parseLambda <|> parseApp <|> parseBraces parseTerm <|> - parseVar <|> - parseLambda + parseLit <|> + parseVar parseTermNoApp :: Parser Term parseTermNoApp = parseBraces parseTerm <|> parseLet <|> parseVar <|> + parseLit <|> parseLambda parseTypeAndTerm :: Parser Term -> Parser TypedTerm @@ -102,8 +108,9 @@ parseType = parseBraces parseType <|> 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 @@ -152,6 +159,25 @@ 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' diff --git a/src/HM/Term.hs b/src/HM/Term.hs index cf4cf36..fc705af 100644 --- a/src/HM/Term.hs +++ b/src/HM/Term.hs @@ -10,13 +10,15 @@ module HM.Term ( -- * Types - VarName + Literal(..) + , VarName , TypeVarName , TypeName , Term(..) , TypedTerm(..) , Type(..) , TypeScheme(..) + , PrimOp(..) ) 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 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 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 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 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 --- 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 - x <- many1 $ satisfy isAsciiLower + x <- many1 letter return $! Var x parseLambda :: Parser Term diff --git a/src/Main.hs b/src/Main.hs index 4ddfe2d..8253f88 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,62 +1,10 @@ -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - 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 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 - (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