CLI.hs

----------------------------------------------------------------------------
-- |
-- Module      :  CSPM.Interpreter.Test.CLI
-- Copyright   :  (c) Fontaine 2008
-- License     :  BSD
-- 
-- Maintainer  :  Fontaine@cs.uni-duesseldorf.de
-- Stability   :  experimental
-- Portability :  GHC-only
--
-- This is mainly useful for testing the functional sub language.
-- This module does not allow tracing of processes
-- (tracing is implemented in an other package).
--
-- 'runFile' loads a CSPM-specification from a file and evaluates an expression in
-- the context of that specification.
--
-- Example:
--
--    'runFile' fib.csp fib(10)
--
-- where the file fib.csp contains:
--    fib(x)= if x <2 then 1 else fib(x-1)+fib(x-2)
--
-- 'runFile' writes to 'stdout' and handles some exceptions.
--
----------------------------------------------------------------------------

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

-- | Load a specification from a file and evaluate an expression in the context.
-- Print the result to 'stdout' and handle some exceptions.
runFile :: FilePath -> String -> IO ()
runFile fileName expr
  = handleLexError lexErrorHandler
      $ handleParseError parseErrorHandler
        $ handleRenameError renameErrorHandler $
  do
    val <- evalTest fileName expr
    putStrLn $ show val
    exitSuccess

-- | Load a specification from a file and evaluate an expression in the context.
evalTest :: FilePath -> String -> IO Value
evalTest fileName expr = liftM fst $ evalEnv False (Just fileName) expr

{- Todo: clean up the mess below -}

-- | Evaluate an expression in an optional context.
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
{- this is a hack:
we simply append the expression to be evaluated at the end of the sourcefile
and parse both together in one go
todo : fix
-}
  let src = srcPlain ++ "\n--patch entrypoint\ntest__entry = " ++expr ++"\n"  

--  putStrLn $ "Reading File " ++ fileName
  _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 () -- force astNew ?
  _time_have_renaming <- getCPUTime

--  putStrLn $ "Parsing OK"
--  putStrLn $ "lextime : " ++ showTime (time_have_tokens - startTime)
--  putStrLn $ "parsetime : " ++ showTime(time_have_ast - time_have_tokens)
--  putStrLn $ "renamingtime : " ++ showTime (time_have_renaming - time_have_ast)
--  putStrLn $ "total : " ++ showTime(time_have_ast - startTime)

  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