some work on HM interpreter

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

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