src/HM/Interpreter.hs

   1 {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}
   2
   3 module HM.Interpreter (
   4     interpret
   5   ) where
   6
   7 import Data.Text as T (Text, pack)
   8 import qualified Data.Text.IO as T
   9 import Data.Attoparsec.Text
  10 import qualified Data.Map as M
  11 import Control.Applicative
  12 import Control.Monad
  13 import System.Environment
  14
  15 import HM
  16 import HM.Term
  17 import HM.Parser
  18
  19 import qualified Lambda as L
  20
  21 data Definition = Definition String TypedTerm
  22
  23 dictionary :: [Definition] -> M.Map VarName TypedTerm
  24 dictionary = M.fromList . map (\ (Definition s t) -> (s, t))
  25
  26 parseDefinition :: Parser Definition
  27 parseDefinition = do
  28   name <- parseVar
  29   char '='
  30   t <- parseTypedTerm
  31   return $! Definition name t
  32
  33 parseImport :: Parser String
  34 parseImport = do
  35   string (T.pack "import ")
  36   many1 letter
  37
  38 parseFile :: Text -> ([FilePath], [Definition], [Term])
  39 parseFile txt = case cnt of
  40     (Right t) -> t
  41     (Left e) -> error e
  42   where cnt = parseOnly (parserF <* endOfInput) txt
  43         parserF = do
  44           imports <- many (parseImport <* char '\n')
  45           defs <- many (parseDefinition <* char '\n')
  46           terms <- many (parseTypedTerm <* char '\n')
  47           return (imports, defs, terms)
  48
  49 printEval :: (Term -> Term) -> Term -> IO ()
  50 printEval def t = do
  51   putStrLn $ show t ++ ":"
  52   putStrLn $ "  " ++ show (reduce $ def t)
  53   putStrLn ""
  54
  55 makeDefTerm :: [Definition] -> Term -> Term
  56 makeDefTerm (Definition name dTerm : ds) t = App (Lambda name (makeDefTerm ds t)) dTerm
  57 makeDefTerm [] t = t
  58
  59 interpret :: FilePath -> IO ()
  60 interpret filename = do
  61   (imports, defs, terms) <- parseFile <$> T.readFile filename
  62   importDefs <- forM imports $ \ file ->  do
  63         (_, idefs, _) <- parseFile <$> T.readFile (file ++ ".hm")
  64         return idefs
  65   let defT = makeDefTerm $ concat importDefs ++ defs
  66   mapM_ (printEval defT) terms