module CSPM.Interpreter.Test.CLI
(
evalTest
,runFile
,evalEnv
)
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,emptyEnvirionment,getLetBindings)
import CSPM.Interpreter.PrepareAST (prepareAST)
import CSPM.Interpreter.Hash
import CSPM.Interpreter.CoreInstances ()
import System.Exit
import System.CPUTime
import Control.Exception (evaluate)
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 False (Just fileName) expr
evalEnv :: Bool -> Maybe FilePath -> String -> IO (Value,Types.Env)
evalEnv verbose context expr = do
srcPlain <- case context of
Just path -> readFile path
Nothing -> return ""
let fileName = fromMaybe "expression" context
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
let
entry :: AST.UniqueIdent
entry = fromJust $ Map.lookup "test__entry" $ (\(x,_,_) -> x) renaming
astP :: LModule
astP = compilePattern astNew
env = processDeclList (hs "TopLevelEnvirionment") emptyEnvirionment
$ AST.moduleDecls $ unLabel astP
val :: Value
val = (IntMap.!) (getLetBindings env) $ AST.uniqueIdentId entry
when verbose $ do
putStrLn $ "eval result : " ++ show val
time_finish_execute <- getCPUTime
putStrLn $ "eval 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