module CSPM.Interpreter.Test.CLI
(
evalTest
,runFile
)
where
import Language.CSPM.Frontend
import qualified Language.CSPM.AST as AST
import CSPM.Interpreter.Eval
import qualified CSPM.Interpreter.Types as Types
import CSPM.Interpreter.Types
(Value,initialEnvirionment,getLetBindings)
import CSPM.Interpreter.PrepareAST (prepareAST)
import CSPM.Interpreter.Hash
import CSPM.Interpreter.CoreInstances ()
import System.Exit
import System.CPUTime
import Control.Monad
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import Data.Maybe
runFile :: FilePath -> String -> IO ()
runFile fileName expr
= handleLexError lexErrorHandler
$ handleParseError parseErrorHandler
$ handleRenameError renameErrorHandler $
do
val <- evalTest fileName expr
putStrLn $ show val
exitSuccess
evalTest :: FilePath -> String -> IO Value
evalTest fileName expr = liftM fst $ evalEnv fileName expr
evalEnv :: FilePath -> String -> IO (Value,Types.Env)
evalEnv fileName expr = do
srcPlain <- readFile fileName
let src = srcPlain ++ "\n--patch entrypoint\ntest__entry = " ++expr ++"\n"
_startTime <- (return $ length src) >> getCPUTime
tokenList <- lexInclude src >>= eitherToExc
_time_have_tokens <- getCPUTime
ast <- eitherToExc $ parse fileName tokenList
_time_have_ast <- getCPUTime
renaming <- eitherToExc $ getRenaming ast
let astNew = prepareAST $ applyRenaming renaming ast
case astNew of Labeled {} -> return ()
_time_have_renaming <- getCPUTime
time_start_execute <- getCPUTime
initEnv <- initialEnvirionment
let
entry :: AST.UniqueIdent
entry = fromJust $ Map.lookup "test__entry" $ (\(x,_,_) -> x) renaming
astP :: LModule
astP = compilePattern astNew
env = processDeclList (hs "TopLevelEnvirionment") initEnv
$ AST.moduleDecls $ unLabel astP
val :: Value
val = (IntMap.!) (getLetBindings env) $ AST.uniqueIdentId entry
putStrLn $ show val
time_finish_execute <- getCPUTime
putStrLn $ "execution time : " ++ showTime(time_finish_execute time_start_execute)
return (val,env)
showTime :: Integer -> String
showTime a = show (div a 1000000000) ++ "ms"
parseErrorHandler :: ParseError -> IO ()
parseErrorHandler err = do
putStrLn "ParseError : "
putStrLn $ show err
exitFailure
lexErrorHandler :: LexError -> IO ()
lexErrorHandler err = do
putStrLn "LexError : "
putStrLn $ show err
exitFailure
renameErrorHandler :: RenameError -> IO ()
renameErrorHandler err = do
putStrLn "RenamingError : "
putStrLn $ show err
exitFailure