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 data Definition = Definition String TypedTerm
  20
  21 dictionary :: [Definition] -> M.Map VarName TypedTerm
  22 dictionary = M.fromList . map (\ (Definition s t) -> (s, t))
  23
  24 parseDefinition :: Parser Definition
  25 parseDefinition = do
  26   name <- parseVar
  27   char '='
  28   t <- parseTypedTerm
  29   return $! Definition name t
  30
  31 parseImport :: Parser String
  32 parseImport = do
  33   string (T.pack "import ")
  34   many1 letter
  35
  36 parseFile :: Text -> ([FilePath], [Definition], [Term])
  37 parseFile txt = case cnt of
  38     (Right t) -> t
  39     (Left e) -> error e
  40   where cnt = parseOnly (parserF <* endOfInput) txt
  41         parserF = do
  42           imports <- many (parseImport <* char '\n')
  43           defs <- many (parseDefinition <* char '\n')
  44           terms <- many (parseTypedTerm <* char '\n')
  45           return (imports, defs, terms)
  46
  47 printEval :: (Term -> Term) -> Term -> IO ()
  48 printEval def t = do
  49   putStrLn $ show t ++ ":"
  50   putStrLn $ "  " ++ show (reduce $ def t)
  51   putStrLn ""
  52
  53 makeDefTerm :: [Definition] -> Term -> Term
  54 makeDefTerm (Definition name dTerm : ds) t = App (Lambda name (makeDefTerm ds t)) dTerm
  55 makeDefTerm [] t = t
  56
  57 interpret :: FilePath -> IO ()
  58 interpret filename = do
  59   (imports, defs, terms) <- parseFile <$> T.readFile filename
  60   importDefs <- forM imports $ \ file ->  do
  61         (_, idefs, _) <- parseFile <$> T.readFile (file ++ ".hm")
  62         return idefs
  63   let defT = makeDefTerm $ concat importDefs ++ defs
  64   mapM_ (printEval defT) terms