src/Lambda/Interpreter.hs

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