{-# LANGUAGE OverloadedStrings #-}
module Funcons.Tools (
mkMain, mkMainWithLibrary, mkMainWithLibraryEntities,
mkMainWithLibraryTypes, mkMainWithLibraryEntitiesTypes,
mkFullyFreshInterpreter, mkFreshInterpreter,
run, runWithExtensions, runWithExtensionsNoCore, runWithExtensionsNoNothing,
FunconLibrary, libEmpty, libUnion, libOverride, libUnions, libOverrides, libFromList,
TypeRelation, DataTypeMembers(..), DataTypeAltt(..), TypeParam,
emptyTypeRelation, typeEnvUnion, typeEnvUnions, typeEnvFromList,
EntityDefaults, EntityDefault(..), noEntityDefaults,
) where
import Funcons.EDSL (library)
import Funcons.RunOptions
import Funcons.Types
import Funcons.Entities
import Funcons.MSOS
import Funcons.Core.Library
import Funcons.Core.Manual
import Funcons.Printer
import System.Environment (getArgs)
import Data.Text (unpack)
import Data.List ((\\), intercalate)
import qualified Data.Map as M
import Control.Monad (forM_, when, unless)
noEntityDefaults :: [EntityDefault]
noEntityDefaults :: [EntityDefault]
noEntityDefaults = []
mkMain :: IO ()
mkMain :: IO ()
mkMain = FunconLibrary -> IO ()
mkMainWithLibrary FunconLibrary
libEmpty
mkMainWithLibrary :: FunconLibrary -> IO()
mkMainWithLibrary :: FunconLibrary -> IO ()
mkMainWithLibrary FunconLibrary
lib = FunconLibrary -> [EntityDefault] -> IO ()
mkMainWithLibraryEntities FunconLibrary
lib []
mkMainWithLibraryEntities :: FunconLibrary -> EntityDefaults -> IO ()
mkMainWithLibraryEntities :: FunconLibrary -> [EntityDefault] -> IO ()
mkMainWithLibraryEntities FunconLibrary
lib [EntityDefault]
ents =
FunconLibrary -> [EntityDefault] -> TypeRelation -> IO ()
mkMainWithLibraryEntitiesTypes FunconLibrary
lib [EntityDefault]
ents TypeRelation
emptyTypeRelation
mkMainWithLibraryTypes :: FunconLibrary -> TypeRelation -> IO ()
mkMainWithLibraryTypes :: FunconLibrary -> TypeRelation -> IO ()
mkMainWithLibraryTypes FunconLibrary
lib TypeRelation
tys = FunconLibrary -> [EntityDefault] -> TypeRelation -> IO ()
mkMainWithLibraryEntitiesTypes FunconLibrary
lib [] TypeRelation
tys
mkMainWithLibraryEntitiesTypes :: FunconLibrary -> EntityDefaults -> TypeRelation -> IO ()
mkMainWithLibraryEntitiesTypes :: FunconLibrary -> [EntityDefault] -> TypeRelation -> IO ()
mkMainWithLibraryEntitiesTypes FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv = do
[String]
args <- IO [String]
getArgs
FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
runWithExtensions FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv [String]
args forall a. Maybe a
Nothing
mkFullyFreshInterpreter :: FunconLibrary -> EntityDefaults -> TypeRelation -> IO ()
mkFullyFreshInterpreter :: FunconLibrary -> [EntityDefault] -> TypeRelation -> IO ()
mkFullyFreshInterpreter FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv = do
[String]
args <- IO [String]
getArgs
FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
runWithExtensionsNoNothing FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv [String]
args forall a. Maybe a
Nothing
mkFreshInterpreter :: FunconLibrary -> EntityDefaults -> TypeRelation -> IO ()
mkFreshInterpreter :: FunconLibrary -> [EntityDefault] -> TypeRelation -> IO ()
mkFreshInterpreter FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv = do
[String]
args <- IO [String]
getArgs
FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
runWithExtensionsNoCore FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv [String]
args forall a. Maybe a
Nothing
runWithExtensions ::
FunconLibrary -> EntityDefaults -> TypeRelation -> [String] -> Maybe Funcons -> IO ()
runWithExtensions :: FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
runWithExtensions FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv =
FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
runWithExtensionsNoCore
([FunconLibrary] -> FunconLibrary
libUnions [FunconLibrary
Funcons.Core.Library.funcons, FunconLibrary
lib])
(forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[EntityDefault]
defaults, forall a. [a]
Funcons.Core.Library.entities])
([TypeRelation] -> TypeRelation
typeEnvUnions [TypeRelation
tyenv, TypeRelation
Funcons.Core.Library.types])
runWithExtensionsNoCore ::
FunconLibrary -> EntityDefaults -> TypeRelation -> [String] -> Maybe Funcons -> IO ()
runWithExtensionsNoCore :: FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
runWithExtensionsNoCore FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv = FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
runWithExtensionsNoNothing FunconLibrary
full_lib [EntityDefault]
defaults TypeRelation
tyenv
where full_lib :: FunconLibrary
full_lib = [FunconLibrary] -> FunconLibrary
libUnions [FunconLibrary
lib
,FunconLibrary
Funcons.EDSL.library
,FunconLibrary
Funcons.Core.Manual.library]
runWithExtensionsNoNothing ::
FunconLibrary -> EntityDefaults -> TypeRelation -> [String] -> Maybe Funcons -> IO ()
runWithExtensionsNoNothing :: FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
runWithExtensionsNoNothing FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv = FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
emulate FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv
run :: [String] -> Maybe Funcons -> IO ()
run :: [String] -> Maybe Funcons -> IO ()
run = FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
runWithExtensions FunconLibrary
libEmpty [] TypeRelation
emptyTypeRelation
emulate :: FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> [String]
-> Maybe Funcons
-> IO ()
emulate FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv [String]
args Maybe Funcons
mf0 = do
(RunOptions
opts, [String]
unknown_opts) <- [String] -> IO (RunOptions, [String])
run_options [String]
args
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [String]
unknown_opts forall a b. (a -> b) -> a -> b
$ \String
arg -> do
String -> IO ()
putStrLn (String
"unknown option: " forall a. [a] -> [a] -> [a]
++ String
arg)
case RunOptions -> Bool
interactive_mode RunOptions
opts of
Bool
True -> forall (m :: * -> *).
Interactive m =>
(Name -> m Funcons)
-> FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> RunOptions
-> Maybe Funcons
-> IO ()
emulate' (forall (m :: * -> *). Interactive m => Bool -> Name -> m Funcons
fread (RunOptions -> Bool
string_inputs RunOptions
opts) :: Name -> IO Funcons) FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv RunOptions
opts Maybe Funcons
mf0
Bool
False -> forall (m :: * -> *).
Interactive m =>
(Name -> m Funcons)
-> FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> RunOptions
-> Maybe Funcons
-> IO ()
emulate' (forall (m :: * -> *). Interactive m => Bool -> Name -> m Funcons
fread (RunOptions -> Bool
string_inputs RunOptions
opts) :: Name -> SimIO Funcons) FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv RunOptions
opts Maybe Funcons
mf0
emulate' :: Interactive m => (Name -> m Funcons) ->
FunconLibrary -> EntityDefaults -> TypeRelation -> RunOptions -> Maybe Funcons -> IO ()
emulate' :: forall (m :: * -> *).
Interactive m =>
(Name -> m Funcons)
-> FunconLibrary
-> [EntityDefault]
-> TypeRelation
-> RunOptions
-> Maybe Funcons
-> IO ()
emulate' Name -> m Funcons
reader FunconLibrary
lib [EntityDefault]
defaults TypeRelation
tyenv RunOptions
opts Maybe Funcons
mf0 = do
let f0 :: Funcons
f0 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (RunOptions -> Funcons
funcon_term RunOptions
opts) forall a. a -> a
id Maybe Funcons
mf0
msos_ctxt :: MSOSReader m
msos_ctxt = forall (m :: * -> *).
RewriteReader
-> InputValues
-> DownControl
-> (Name -> m Funcons)
-> MSOSReader m
MSOSReader (FunconLibrary
-> TypeRelation
-> RunOptions
-> Funcons
-> Funcons
-> RewriteReader
RewriteReader FunconLibrary
lib TypeRelation
tyenv RunOptions
opts Funcons
f0 Funcons
f0) InputValues
emptyINH DownControl
emptyDCTRL Name -> m Funcons
reader
((Either IException StepRes
e_exc_f, MSOSState m
mut, MSOSWriter
wr), InputValues
rem_ins) <-
forall (m :: * -> *) a.
Interactive m =>
m a -> InputValues -> IO (a, InputValues)
fexec (forall a.
MSOS a
-> forall (m :: * -> *).
Interactive m =>
MSOSReader m
-> MSOSState m -> m (Either IException a, MSOSState m, MSOSWriter)
runMSOS ([EntityDefault] -> MSOS StepRes -> MSOS StepRes
setEntityDefaults [EntityDefault]
defaults (RunOptions -> Int -> StepRes -> MSOS StepRes
stepTrans RunOptions
opts Int
0 (Funcons -> StepRes
toStepRes Funcons
f0)))
MSOSReader m
msos_ctxt ((forall (m :: * -> *). Int -> MSOSState m
emptyMSOSState (RunOptions -> Int
random_seed RunOptions
opts)){inp_es :: Input m
inp_es = forall {a}. Map Name ([a], Maybe (m Funcons))
inputs})) (RunOptions -> InputValues
inputValues RunOptions
opts)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RunOptions -> Bool
interactive_mode RunOptions
opts)
(forall {m :: * -> *}.
[EntityDefault]
-> MSOSReader m
-> Either IException StepRes
-> MSOSState m
-> MSOSWriter
-> InputValues
-> IO ()
withResults [EntityDefault]
defaults MSOSReader m
msos_ctxt Either IException StepRes
e_exc_f MSOSState m
mut MSOSWriter
wr InputValues
rem_ins)
where inputs :: Map Name ([a], Maybe (m Funcons))
inputs = forall k a b. (k -> a -> b -> b) -> b -> Map k a -> b
M.foldrWithKey forall {p} {a}.
Name
-> p
-> Map Name ([a], Maybe (m Funcons))
-> Map Name ([a], Maybe (m Funcons))
op forall k a. Map k a
M.empty (RunOptions -> InputValues
inputValues RunOptions
opts)
where op :: Name
-> p
-> Map Name ([a], Maybe (m Funcons))
-> Map Name ([a], Maybe (m Funcons))
op Name
nm p
_ = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
nm ([], forall a. a -> Maybe a
Just (Name -> m Funcons
reader Name
nm))
withResults :: [EntityDefault]
-> MSOSReader m
-> Either IException StepRes
-> MSOSState m
-> MSOSWriter
-> InputValues
-> IO ()
withResults [EntityDefault]
defaults MSOSReader m
msos_ctxt Either IException StepRes
e_exc_f MSOSState m
msos_state MSOSWriter
wr InputValues
rem_ins
| RunOptions -> Bool
show_tests RunOptions
opts =
case Either IException StepRes
e_exc_f of
Left IException
ie -> String -> IO ()
putStrLn (IException -> String
showIException IException
ie)
Right StepRes
efvs -> forall (m :: * -> *).
[Funcons]
-> [EntityDefault]
-> MSOSReader m
-> MSOSState m
-> MSOSWriter
-> InputValues
-> IO ()
printTestResults (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. a -> [a] -> [a]
:[]) (forall a b. (a -> b) -> [a] -> [b]
map Values -> Funcons
FValue) StepRes
efvs)
[EntityDefault]
defaults MSOSReader m
msos_ctxt MSOSState m
msos_state MSOSWriter
wr InputValues
rem_ins
| Bool
otherwise = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RunOptions -> Bool
show_output_only RunOptions
opts) forall a b. (a -> b) -> a -> b
$ do
IO ()
printCounts
case Either IException StepRes
e_exc_f of
Left IException
ie -> String -> IO ()
putStrLn (IException -> String
showIException IException
ie)
Right StepRes
f -> [Funcons] -> IO ()
printResult (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. a -> [a] -> [a]
:[]) (forall a b. (a -> b) -> [a] -> [b]
map Values -> Funcons
FValue) StepRes
f)
IO ()
printMutable
IO ()
printControl
InputValues -> [Name] -> IO ()
printInput InputValues
rem_ins (RunOptions -> [Name]
hide_input RunOptions
opts)
IO ()
printOutput
where
muts :: InputValues
muts = forall (m :: * -> *). MSOSState m -> InputValues
mut_entities MSOSState m
msos_state
opts :: RunOptions
opts = RewriteReader -> RunOptions
run_opts (forall (m :: * -> *). MSOSReader m -> RewriteReader
ereader MSOSReader m
msos_ctxt)
printResult :: [Funcons] -> IO ()
printResult [Funcons]
f = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RunOptions -> Bool
show_result RunOptions
opts) forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn String
"Result:"
String -> IO ()
putStrLn (RunOptions -> [Funcons] -> String
ppFunconsSeq RunOptions
opts [Funcons]
f)
String -> IO ()
putStrLn String
""
printCounts :: IO ()
printCounts = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RunOptions -> Bool
show_counts RunOptions
opts) forall a b. (a -> b) -> a -> b
$ do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (RunOptions -> Bool
csv_output_with_keys RunOptions
opts) (String -> IO ()
putStrLn String
counterKeys)
if (RunOptions -> Bool
csv_output RunOptions
opts)
then String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ Counters -> String
displayCounters (RewriteWriterr -> Counters
counters (MSOSWriter -> RewriteWriterr
ewriter MSOSWriter
wr))
else String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ Counters -> String
ppCounters (RewriteWriterr -> Counters
counters (MSOSWriter -> RewriteWriterr
ewriter MSOSWriter
wr))
printMutable :: IO ()
printMutable = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Name]
toShow Name -> IO ()
display
where toShow :: [Name]
toShow = RunOptions -> [Name]
show_mutable RunOptions
opts
display :: Name -> IO ()
display Name
name = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name InputValues
muts of
Maybe [Values]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [Values]
v -> String -> IO ()
putStrLn (String
"Mutable Entity: " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
String -> IO ()
putStrLn ([Values] -> String
displayValues [Values]
v) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
""
printControl :: IO ()
printControl = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [k]
M.keys DownControl
ctrl forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
toHide) Name -> IO ()
display
where ctrl :: DownControl
ctrl = MSOSWriter -> DownControl
ctrl_entities MSOSWriter
wr
toHide :: [Name]
toHide = RunOptions -> [Name]
hide_control RunOptions
opts
display :: Name -> IO ()
display Name
name = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name DownControl
ctrl of
Just (Just Values
v) -> do
String -> IO ()
putStrLn (String
"Control Entity: " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name)
String -> IO ()
putStrLn (Values -> String
displayValue Values
v) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> IO ()
putStrLn String
""
Maybe (Maybe Values)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
printOutput :: IO ()
printOutput = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [k]
M.keys InputValues
out forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
toHide) Name -> IO ()
display
where out :: InputValues
out = MSOSWriter -> InputValues
out_entities MSOSWriter
wr
display :: Name -> IO ()
display Name
name = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RunOptions -> Bool
show_output_only RunOptions
opts)
(String -> IO ()
putStrLn (String
"Output Entity: " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name))
case forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall t. HasValues t => Values t -> Bool
isString_ [Values]
vs Bool -> Bool -> Bool
&& RunOptions -> Bool
pp_string_outputs RunOptions
opts of
Bool
True -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (String -> IO ()
putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. HasValues t => Values t -> String
unString) [Values]
vs
Bool
False -> String -> IO ()
putStrLn ([Values] -> String
displayValues [Values]
vs)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (RunOptions -> Bool
show_output_only RunOptions
opts) (String -> IO ()
putStrLn String
"")
where vs :: [Values]
vs = InputValues
out forall k a. Ord k => Map k a -> k -> a
M.! Name
name
toHide :: [Name]
toHide = RunOptions -> [Name]
hide_output RunOptions
opts
printInput :: InputValues -> [Name] -> IO ()
printInput InputValues
ios [Name]
toHide = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [k]
M.keys InputValues
ios forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
toHide) Name -> IO ()
display
where display :: Name -> IO ()
display Name
name = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Values]
vs) forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn (String
"Input Entity: " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name)
String -> IO ()
putStrLn ([Values] -> String
displayValues [Values]
vs)
String -> IO ()
putStrLn String
""
where vs :: [Values]
vs = InputValues
ios forall k a. Ord k => Map k a -> k -> a
M.! Name
name
displayValues :: [Values] -> String
displayValues [Values]
vs = forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map Values -> String
displayValue [Values]
vs)
displayValue :: Values -> String
displayValue (Map ValueMaps Values
m) = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n"
[ Values -> String
displayValue Values
key forall a. [a] -> [a] -> [a]
++ String
" |-> " forall a. [a] -> [a] -> [a]
++ [Values] -> String
displayValues [Values]
val
| (Values
key, [Values]
val) <- forall k a. Map k a -> [(k, a)]
M.assocs ValueMaps Values
m ]
displayValue (ADTVal Name
"variable" [FValue (Atom String
a)
,FValue (ComputationType (Type Types Funcons
t))]) =
String
"variable(" forall a. [a] -> [a] -> [a]
++ Values -> String
displayValue (forall t. String -> Values t
Atom String
a) forall a. [a] -> [a] -> [a]
++ String
", " forall a. [a] -> [a] -> [a]
++ forall t. HasValues t => (t -> String) -> Types t -> String
ppTypes (RunOptions -> Funcons -> String
ppFuncons RunOptions
opts) Types Funcons
t forall a. [a] -> [a] -> [a]
++ String
")"
displayValue (Atom String
a) = String
a
displayValue Values
val | forall t. HasValues t => Values t -> Bool
isString_ Values
val = forall a. Show a => a -> String
show (forall t. HasValues t => Values t -> String
unString Values
val)
displayValue Values
val = forall t. HasValues t => (t -> String) -> Values t -> String
ppValues (RunOptions -> Funcons -> String
ppFuncons RunOptions
opts) Values
val
printTestResults :: [Funcons] -> EntityDefaults -> MSOSReader m ->
MSOSState m -> MSOSWriter -> InputValues -> IO ()
printTestResults :: forall (m :: * -> *).
[Funcons]
-> [EntityDefault]
-> MSOSReader m
-> MSOSState m
-> MSOSWriter
-> InputValues
-> IO ()
printTestResults [Funcons]
fs [EntityDefault]
defaults MSOSReader m
msos_ctxt MSOSState m
msos_state MSOSWriter
wr InputValues
rem_ins = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [k]
M.keys TestOptions
opts) Name -> IO ()
printNotExists
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall k a. Ord k => k -> Map k a -> Bool
M.member Name
"result-term" TestOptions
opts) forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Funcons]
result_term forall a. Eq a => a -> a -> Bool
== [Funcons]
fs) (Name -> String -> String -> IO ()
reportError Name
"result-term" ([Funcons] -> String
showFunconsSeq [Funcons]
result_term) ([Funcons] -> String
showFunconsSeq [Funcons]
fs))
IO ()
printMutable
IO ()
printControl
InputValues -> IO ()
printInputOutput InputValues
out
InputValues -> IO ()
printInputOutput InputValues
rem_ins
where eval_ctxt :: RewriteReader
eval_ctxt = forall (m :: * -> *). MSOSReader m -> RewriteReader
ereader MSOSReader m
msos_ctxt
muts :: InputValues
muts = forall (m :: * -> *). MSOSState m -> InputValues
mut_entities MSOSState m
msos_state
eval_state :: RewriteState
eval_state = forall (m :: * -> *). MSOSState m -> RewriteState
estate MSOSState m
msos_state
localEval :: Name -> Funcons -> Values
localEval Name
name Funcons
term = case forall a.
Rewrite a
-> RewriteReader
-> RewriteState
-> (Either IException a, RewriteState, RewriteWriterr)
runRewrite (Funcons -> Rewrite Rewritten
rewriteFuncons Funcons
term) RewriteReader
eval_ctxt RewriteState
eval_state
of (Left IException
ie,RewriteState
_,RewriteWriterr
_) -> forall a. HasCallStack => String -> a
error (String
"internal exception in " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name
forall a. [a] -> [a] -> [a]
++ String
" evaluation:\n" forall a. [a] -> [a] -> [a]
++ IException -> String
showIException IException
ie)
(Right (ValTerm [Values
v]),RewriteState
_,RewriteWriterr
_) -> Values
v
(Right (ValTerm [Values]
vs),RewriteState
_,RewriteWriterr
_) -> forall a. HasCallStack => String -> a
error
(String
"evaluation of " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name forall a. [a] -> [a] -> [a]
++ String
" results in sequence")
(Right Rewritten
_,RewriteState
_,RewriteWriterr
_) ->
forall a. HasCallStack => String -> a
error (String
"evaluation of " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name forall a. [a] -> [a] -> [a]
++ String
" requires step")
mLocalEval :: Funcons -> Maybe Values
mLocalEval Funcons
term = case forall a.
Rewrite a
-> RewriteReader
-> RewriteState
-> (Either IException a, RewriteState, RewriteWriterr)
runRewrite(Funcons -> Rewrite Rewritten
rewriteFuncons Funcons
term) RewriteReader
eval_ctxt RewriteState
eval_state of
(Right (ValTerm [Values
v]),RewriteState
_,RewriteWriterr
_) -> forall a. a -> Maybe a
Just Values
v
(Either IException Rewritten, RewriteState, RewriteWriterr)
_ -> forall a. Maybe a
Nothing
result_term :: [Funcons]
result_term = case forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Funcons -> Maybe Values
recursiveFunconValue [Funcons]
rf) of
Maybe [Values]
Nothing -> case forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Funcons -> Maybe Values
mLocalEval [Funcons]
rf) of
Maybe [Values]
Nothing -> [Funcons]
rf
Just [Values]
vs -> forall a b. (a -> b) -> [a] -> [b]
map Values -> Funcons
FValue [Values]
vs
Just [Values]
vs -> forall a b. (a -> b) -> [a] -> [b]
map Values -> Funcons
FValue [Values]
vs
where rf :: [Funcons]
rf = (TestOptions
opts forall k a. Ord k => Map k a -> k -> a
M.! Name
"result-term")
opts :: TestOptions
opts = RunOptions -> TestOptions
expected_outcomes (RewriteReader -> RunOptions
run_opts RewriteReader
eval_ctxt)
reportError :: Name -> String -> String -> IO ()
reportError Name
name String
expected String
actual = do
String -> IO ()
putStrLn (String
"expected " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
expected)
String -> IO ()
putStrLn (String
"actual " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ String
actual)
printNotExists :: Name -> IO ()
printNotExists Name
"result-term" = forall (m :: * -> *) a. Monad m => a -> m a
return ()
printNotExists Name
name =
case (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name InputValues
muts, forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name InputValues
out
,forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name DownControl
ctrl, forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name InputValues
rem_ins) of
(Maybe [Values]
Nothing, Maybe [Values]
Nothing, Maybe (Maybe Values)
Nothing, Maybe [Values]
Nothing) ->
String -> IO ()
putStrLn (String
"unknown entity: " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name)
(Maybe [Values], Maybe [Values], Maybe (Maybe Values),
Maybe [Values])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
printMutable :: IO ()
printMutable = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
M.assocs InputValues
muts) (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> [Values] -> IO ()
display)
where display :: Name -> [Values] -> IO ()
display Name
name [Values]
vals = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name TestOptions
opts of
Maybe [Funcons]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [Funcons]
expected -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
(forall a b. (a -> b) -> [a] -> [b]
map (Name -> Funcons -> Values
localEval Name
name) [Funcons]
expected forall a. Eq a => a -> a -> Bool
== [Values]
vals)
(Name -> String -> String -> IO ()
reportError Name
name ([String] -> String
showL forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Funcons -> String
showFuncons [Funcons]
expected) ([String] -> String
showL forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Values -> String
showValues [Values]
vals))
ctrl :: M.Map Name (Maybe Values)
ctrl :: DownControl
ctrl = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}.
EntityDefault -> Map Name (Maybe a) -> Map Name (Maybe a)
op (MSOSWriter -> DownControl
ctrl_entities MSOSWriter
wr) [EntityDefault]
defaults
where op :: EntityDefault -> Map Name (Maybe a) -> Map Name (Maybe a)
op (DefControl Name
name) Map Name (Maybe a)
ctrl
| Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member Name
name Map Name (Maybe a)
ctrl) = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name forall a. Maybe a
Nothing Map Name (Maybe a)
ctrl
op EntityDefault
_ Map Name (Maybe a)
ctrl = Map Name (Maybe a)
ctrl
out :: InputValues
out = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {a}. EntityDefault -> Map Name [a] -> Map Name [a]
op (MSOSWriter -> InputValues
out_entities MSOSWriter
wr) [EntityDefault]
defaults
where op :: EntityDefault -> Map Name [a] -> Map Name [a]
op (DefOutput Name
name) Map Name [a]
out
| Bool -> Bool
not (forall k a. Ord k => k -> Map k a -> Bool
M.member Name
name Map Name [a]
out) = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
name [] Map Name [a]
out
op EntityDefault
_ Map Name [a]
out = Map Name [a]
out
printControl :: IO ()
printControl = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
M.assocs DownControl
ctrl) (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Maybe Values -> IO ()
display)
where display :: Name -> Maybe Values -> IO ()
display :: Name -> Maybe Values -> IO ()
display Name
name Maybe Values
Nothing = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name TestOptions
opts of
Maybe [Funcons]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just [Funcons]
vals -> String -> IO ()
putStrLn (String
"expected "forall a. [a] -> [a] -> [a]
++Name -> String
unpack Name
nameforall a. [a] -> [a] -> [a]
++String
": "
forall a. [a] -> [a] -> [a]
++ [String] -> String
showL (forall a b. (a -> b) -> [a] -> [b]
map (Values -> String
showValues forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Funcons -> Values
localEval Name
name) [Funcons]
vals))
display Name
name (Just Values
val) = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name TestOptions
opts of
Maybe [Funcons]
Nothing -> String -> IO ()
putStrLn (String
"unexpected " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ Values -> String
showValues Values
val)
Just [Funcons]
expected -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
(forall a b. (a -> b) -> [a] -> [b]
map (Name -> Funcons -> Values
localEval Name
name) [Funcons]
expected forall a. Eq a => a -> a -> Bool
== [Values
val])
(Name -> String -> String -> IO ()
reportError Name
name ([String] -> String
showL forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Funcons -> String
showFuncons [Funcons]
expected) (Values -> String
showValues Values
val))
printInputOutput :: InputValues -> IO ()
printInputOutput InputValues
remaining = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall k a. Map k a -> [(k, a)]
M.assocs InputValues
remaining) (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> [Values] -> IO ()
display)
where
display :: Name -> [Values] -> IO ()
display Name
name [] | Maybe [Funcons]
Nothing <- forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name TestOptions
opts = forall (m :: * -> *) a. Monad m => a -> m a
return ()
display Name
name [Values]
vals = case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name TestOptions
opts of
Maybe [Funcons]
Nothing -> String -> IO ()
putStrLn (String
"unexpected " forall a. [a] -> [a] -> [a]
++ Name -> String
unpack Name
name forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ [String] -> String
showL (forall a b. (a -> b) -> [a] -> [b]
map Values -> String
showValues [Values]
vals))
Just [Funcons]
expected -> case forall a b. (a -> b) -> [a] -> [b]
map (Name -> Funcons -> Values
localEval Name
name) [Funcons]
expected of
[ADTVal Name
"list" [Funcons]
exps] -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Funcons]
exps forall a. Eq a => a -> a -> Bool
== forall a b. (a -> b) -> [a] -> [b]
map Values -> Funcons
FValue [Values]
vals) (Name -> String -> String -> IO ()
reportError Name
name ([String] -> String
showL forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Funcons -> String
showFuncons [Funcons]
exps) ([String] -> String
showL forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Values -> String
showValues [Values]
vals))
[Values]
val -> forall a. HasCallStack => String -> a
error (String
"non-list given as expected output entity ("forall a. [a] -> [a] -> [a]
++
Name -> String
unpack Name
name forall a. [a] -> [a] -> [a]
++ String
"): " forall a. [a] -> [a] -> [a]
++ [String] -> String
showL (forall a b. (a -> b) -> [a] -> [b]
map Values -> String
showValues [Values]
val))