{-# LANGUAGE OverloadedStrings, TupleSections, FlexibleContexts #-}
module Funcons.RunOptions where
import Funcons.Types
import Funcons.GLLParser (Parser(..), pFunconsSeq, pFuncons, fct_lexerSettings)
import Funcons.Parser (fct_parse)
import GLL.Combinators hiding (chooses)
import qualified Data.Map as M
import Control.Monad (when)
import Control.Compose (OO(..))
import Data.Text (pack)
import Data.List (isSuffixOf, isPrefixOf)
import Data.List.Split (splitOn)
import System.Directory (doesFileExist)
type GeneralOptions = M.Map Name String
type BuiltinFunconsOptions = M.Map Name Funcons
type TestOptions = M.Map Name [Funcons]
type InputValues = M.Map Name [Values]
data RunOptions = RunOptions {
mfuncon_term :: Maybe Funcons
, general_opts :: GeneralOptions
, builtin_funcons :: BuiltinFunconsOptions
, expected_outcomes :: TestOptions
, given_inputs :: InputValues
}
defaultRunOptions :: RunOptions
defaultRunOptions = RunOptions Nothing M.empty M.empty M.empty M.empty
optionsOverride opts opts' = RunOptions
(maybe (mfuncon_term opts) Just (mfuncon_term opts'))
(general_opts opts `M.union` general_opts opts')
(builtin_funcons opts `M.union` builtin_funcons opts')
(expected_outcomes opts `M.union` expected_outcomes opts')
(given_inputs opts `M.union` given_inputs opts')
funcon_term :: RunOptions -> Funcons
funcon_term = maybe err id . mfuncon_term
where err = error "Please give a .fct file as an argument or use the --funcon-term flag"
bool_opt_default :: Bool -> Name -> M.Map Name String -> Bool
bool_opt_default def nm m = case M.lookup nm m of
Nothing -> def
Just "false" -> False
_ -> True
bool_opt :: Name -> M.Map Name String -> Bool
bool_opt nm m = bool_opt_default False nm m
do_refocus :: RunOptions -> Bool
do_refocus opts = bool_opt_default True "refocus" (general_opts opts)
max_restarts :: RunOptions -> Maybe Int
max_restarts = fmap read . M.lookup "max-restarts" . general_opts
do_abrupt_terminate :: RunOptions -> Bool
do_abrupt_terminate = not . bool_opt "no-abrupt-termination" . general_opts
pp_full_environments :: RunOptions -> Bool
pp_full_environments = bool_opt "full-environments" . general_opts
show_result :: RunOptions -> Bool
show_result opts = if bool_opt "hide-result" (general_opts opts)
then False
else not (interactive_mode opts)
show_counts :: RunOptions -> Bool
show_counts opts = if bool_opt "display-steps" (general_opts opts)
then not (interactive_mode opts)
else False
show_mutable :: RunOptions -> [Name]
show_mutable = maybe [] (map pack . splitOn ",") . M.lookup "display-mutable-entity" . general_opts
hide_output :: RunOptions -> [Name]
hide_output = maybe [] (map pack . splitOn ",") . M.lookup "hide-output-entity" . general_opts
hide_input :: RunOptions -> [Name]
hide_input = maybe [] (map pack . splitOn ",") . M.lookup "hide-input-entity" . general_opts
hide_control :: RunOptions -> [Name]
hide_control = maybe [] (map pack . splitOn ",") . M.lookup "hide-control-entity" . general_opts
interactive_mode :: RunOptions -> Bool
interactive_mode opts =
M.null (inputValues opts) && bool_opt "interactive-mode" (general_opts opts)
pp_string_outputs :: RunOptions -> Bool
pp_string_outputs = bool_opt "format-string-outputs" . general_opts
string_inputs :: RunOptions -> Bool
string_inputs = bool_opt "string-inputs" . general_opts
show_tests :: RunOptions -> Bool
show_tests opts = if bool_opt "hide-tests" (general_opts opts)
then False
else M.size (expected_outcomes opts) > 0
show_output_only :: RunOptions -> Bool
show_output_only opts = if bool_opt "show-output-only" (general_opts opts)
then True
else interactive_mode opts
auto_config :: RunOptions -> Bool
auto_config opts = bool_opt_default True "auto-config" (general_opts opts)
csv_output :: RunOptions -> Bool
csv_output opts = if bool_opt "csv" (general_opts opts)
then True
else csv_output_with_keys opts
csv_output_with_keys :: RunOptions -> Bool
csv_output_with_keys opts = bool_opt "csv-keys" (general_opts opts)
inputValues :: RunOptions -> InputValues
inputValues = given_inputs
booleanOptions =
["refocus", "full-environments", "hide-result", "display-steps"
,"no-abrupt-termination", "interactive-mode", "string-inputs"
,"format-string-outputs", "hide-tests", "show-output-only"
,"auto-config", "csv", "csv-keys"]
booleanOptions_ = map ("--" ++) booleanOptions
stringOptions = ["display-mutable-entity", "hide-output-entity"
, "hide-control-entity", "hide-input-entity", "max-restarts"]
stringOptions_ = map ("--" ++) stringOptions
allOptions = "funcon-term" : booleanOptions ++ stringOptions
allOptions_ = "--funcon-term" : booleanOptions_ ++ stringOptions_
run_options :: [String] -> IO (RunOptions, [String])
run_options = fold (defaultRunOptions, [])
where fold (opts,errors) (arg:args)
| arg `elem` booleanOptions_ =
let (val, rest)
| not (null args)
, not (isPrefixOf "--" (head args)) = (head args, tail args)
| otherwise = ("true", args)
opts' = opts {general_opts = M.insert (pack (tail (tail arg)))
val (general_opts opts)}
in fold (opts',errors) rest
| arg `elem` stringOptions_ && length args > 0 =
let opts' = opts {general_opts = M.insert (pack (tail (tail arg)))
(head args) (general_opts opts)}
in fold (opts', errors) (tail args)
| arg == "--funcon-term" && length args > 0 =
let opts' = opts {mfuncon_term = Just (fct_parse (head args))}
in fold (opts', errors) (tail args)
| isSuffixOf ".fct" arg = do
fct <- readFile arg
let cfg_name = take (length arg - 4) arg ++ ".config"
exists <- doesFileExist cfg_name
opts' <- if exists && auto_config opts
then readFile cfg_name >>=
return . flip (parseAndApplyConfig cfg_name) opts
else return opts
let opts'' = opts' {mfuncon_term = Just (fct_parse fct)}
fold (opts'', errors) args
| isSuffixOf ".config" arg = fold (opts, errors) ("--config":arg:args)
| arg == "--config" && length args > 0 = do
let cfg_name = head args
exists <- doesFileExist cfg_name
when (not exists) (error ("config file not found: " ++ cfg_name))
str <- readFile cfg_name
let opts' = parseAndApplyConfig cfg_name str opts
fold (opts', errors) (tail args)
| otherwise = do
exists <- doesFileExist (arg++".fct")
if exists then fold (opts, errors) ((arg++".fct"):args)
else fold (opts, arg:errors) args
fold (opts, errors) [] = return (opts, errors)
parseAndApplyConfig :: FilePath -> String -> RunOptions -> RunOptions
parseAndApplyConfig fp str = optionsOverride (config_parser str)
config_parser :: String -> RunOptions
config_parser string = case GLL.Combinators.parseWithOptions [maximumPivot,throwErrors] pRunOptions
(Funcons.RunOptions.lexer string) of
[] -> error "no parse (config)"
(c:_) -> c
lexer :: String -> [Token]
lexer = GLL.Combinators.lexer cfg_lexerSettings
cfg_lexerSettings = fct_lexerSettings {
keywords = (keywords fct_lexerSettings) ++ cfg_keywords
, keychars = (keychars fct_lexerSettings) ++ cfg_keychars
}
cfg_keychars = ":;="
cfg_keywords = allOptions ++ ["result-term", "general", "tests", "funcons", "inputs"]
pRunOptions :: Parser RunOptions
pRunOptions = "SPECS"
<:=> foldr optionsOverride defaultRunOptions <$$> multiple pSpec
pSpec :: Parser RunOptions
pSpec = "SPEC"
<:=> keyword "general" **> braces pGeneral
<||> keyword "tests" **> braces pTestOutcomes
<||> keyword "funcons" **> braces pBuiltinFuncons
<||> keyword "inputs" **> braces pInputValues
pGeneral :: Parser RunOptions
pGeneral = "GENERAL"
<:=> toOpts <$$>
optional (id <$$ keyword "funcon-term" <** keychar ':' <**> pFuncons <** keychar ';')
<**> (M.fromList <$$> multiple pKeyValues)
where toOpts mf gen = defaultRunOptions {mfuncon_term = mf, general_opts = gen}
pKeyValues = "GENERAL-KEYVALUES" <:=> pBoolOpts <||> pStringOpts
where pBoolOpts = "GENERAL-BOOLS" `chooses` (map pKeyValue booleanOptions)
where pKeyValue key = (pack key,) . maybe "true" id
<$$ keyword key <**> optional (keychar ':' **> pBool)
<** keychar ';'
pStringOpts = "GENERAL-STRINGS" `chooses` (map pKeyValue stringOptions)
where pKeyValue key = (pack key,) <$$ keyword key <** keychar ':'
<**> pStringValue <** keychar ';'
chooses p alts = (<::=>) p (OO alts)
pBool :: Parser String
pBool = "BOOL-VALUE" <:=> id_lit
pStringValue :: Parser String
pStringValue = "STRING-VALUE" <:=> id_lit <||> string_lit
pFunconName :: Parser String
pFunconName = "FUNCON-NAME" <:=> id_lit
pTestOutcomes :: Parser RunOptions
pTestOutcomes = "TEST-OUTCOMES"
<:=> toOptions <$$> (M.union <$$> pResult <**> pEntityValues)
where pResult = mStoreResult <$$>
optional (id <$$ keyword "result-term" <** keychar ':'
<**> pFunconsSeq <** keychar ';')
where mStoreResult Nothing = M.empty
mStoreResult (Just f) = M.singleton "result-term" f
pEntityValues = "TEST-ENTITIES" <:=> M.fromList <$$> multiple
((,) . pack <$$> pFunconName <** keychar ':' <**> pFunconsSeq <** keychar ';')
toOptions map = defaultRunOptions { expected_outcomes = map }
pBuiltinFuncons :: Parser RunOptions
pBuiltinFuncons = "BUILTIN-FUNCONS"
<:=> insertFuncons <$$> multiple ((,) . pack <$$> pFunconName <** keychar '='
<**> pFuncons <** keychar ';')
where insertFuncons list = defaultRunOptions {builtin_funcons = M.fromList list}
pInputValues :: Parser RunOptions
pInputValues = "INPUT-VALUES"
<:=> insertInputs <$$> multiple (toPair <$$> pFunconName <** keychar ':'
<**> pFunconsSeq <** keychar ';')
where insertInputs list = defaultRunOptions { given_inputs = M.fromList list }
toPair nm fs = case sequence (map recursiveFunconValue fs) of
Just vs -> (pack nm, vs)
_ -> error ("inputs for " ++ nm ++ " not a sequence of values")