module CSPM.Interpreter.Test.CLI
(
runFile
,evalFile
,evalString
)
where
import Language.CSPM.Frontend
import qualified Language.CSPM.AST as AST
import qualified CSPM.Interpreter.Types as Types
import CSPM.Interpreter.Eval
import CSPM.Interpreter.Types (Value)
import CSPM.Interpreter.PrepareAST (prepareAST)
import CSPM.Interpreter.CoreInstances ()
import System.Exit
import System.CPUTime
import Control.Exception.Base (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
res <- evalFile False (Just fileName) expr
putStrLn $ show $ fst res
exitSuccess
evalFile ::
Bool
-> Maybe FilePath
-> String
-> IO (Value, Types.Env)
evalFile verbose context expr = do
plainSrc <- case context of
Just path -> readFile path
Nothing -> return ""
evalString verbose plainSrc (fromMaybe "expression" context) expr
evalString ::
Bool
-> String
-> String
-> String
-> IO (Value, Types.Env)
evalString verbose specSrc specName expr = do
let src = specSrc ++ "\n--patch entrypoint\ntest__entry = " ++expr ++"\n"
_startTime <- (return $ length src) >> getCPUTime
tokenList <- lexInclude src >>= eitherToExc
_time_have_tokens <- getCPUTime
ast <- eitherToExc $ parse specName tokenList
_time_have_ast <- getCPUTime
(renamedAst, renaming) <- eitherToExc $ renameModule ast
astNew <- evaluate $ prepareAST renamedAst
_time_have_renaming <- getCPUTime
time_start_execute <- getCPUTime
let
entry :: AST.UniqueIdent
entry = fromJust $ Map.lookup "test__entry" $ visible renaming
env = evalModule astNew
val :: Value
val = (IntMap.!) (Types.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