funcons-lambda-cbv-mp-0.1.0.0: src/Main.hs

module Main where

import GLL.Combinators
import Funcons.EDSL
import Funcons.Core.Manual
import Funcons.Core
import Funcons.Tools hiding (mkMain)
import qualified Funcons.MetaProgramming as MP

import LambdaCBV.Parser (parser, builtins, lexerSettings, astLib)

import qualified Data.Map as M
import Data.Text (unpack)

import System.Environment
import Control.Monad

cbv_library = libUnions [astLib,MP.library]
cmp_library = libUnions 
  [Funcons.Core.funcons, cbv_library, Funcons.EDSL.library, Funcons.Core.Manual.library]

main :: IO ()
main = mkMain (lexer lexerSettings) parser id pipeline

pipeline args f =  
  fct_evaluator args (Just (MP.compile cmp_library Funcons.Core.types builtins f))

fct_evaluator = runWithExtensions cbv_library noEntityDefaults emptyTypeRelation

mkMain :: (Show ast) =>
               (String -> [token])            -- lexer
            -> ([token] -> [ast])             -- parser
            -> (ast -> Either String Funcons) -- translator
            -> ([String] -> Funcons -> IO ()) -- evaluator (with args)
            -> IO ()                          -- behaviour
mkMain lexer parser translator evaluator = do
    args <- getArgs
    case args of 
      []        -> putStrLn "Please provide me with an input file"
      f:opts    -> go f opts
 where
    go :: FilePath -> [String] -> IO ()
    go f opts = do 
        str <- readFile f
        let tokens = lexer str
            mast   = parser tokens
            multiple = length mast > 1
        forM_ (zip [1..] mast) $ \(i, ast) -> do
            when multiple (putStrLn ("=== Interpretation "++ show i ++ "\n"))
            when debug $ do print "AST:"
                            print $ ast 
            case translator ast of
              Left err -> putStrLn ("Translation error: \n" ++ err)
              Right f0 -> do
                when debug $ do print "FCT:"
                                putStrLn (showFuncons f0) 
                evaluator opts f0
     where  use_funcons = all ((/=) "--ags") opts
            debug       = any ((==) "--debug") opts