RunOptions.hs

{-# LANGUAGE OverloadedStrings, TupleSections #-}

module Funcons.RunOptions where

import Funcons.Types
import Funcons.Parser

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import qualified Text.ParserCombinators.Parsec.Language as L 

import qualified Data.Map as M
import Control.Monad (when)
import Data.Char (isSpace)
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 "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 = if bool_opt "interactive-mode" (general_opts opts)
    then M.null (inputValues opts) 
    else False

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)

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"]
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 (read (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 (read 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 (parser pRunOptions fp str)

pRunOptions :: Parser RunOptions
pRunOptions = foldr optionsOverride defaultRunOptions <$> 
                    many (choice [  keyword "general" *> braces pGeneral
                                 ,  keyword "funcons" *> braces pBuiltinFuncons
                                 ,  keyword "tests" *> braces pTestOutcomes
                                 ,  keyword "inputs" *> braces pInputValues ] )
 where  runOptions :: Maybe RunOptions -> Maybe BuiltinFunconsOptions -> 
                        Maybe TestOptions -> RunOptions
        runOptions mopts mbin mtests = let opts = maybe defaultRunOptions id mopts
                in opts { builtin_funcons = maybe M.empty id mbin
                        , expected_outcomes = maybe M.empty id mtests }

pGeneral :: Parser RunOptions
pGeneral = toOpts <$> 
                (optionMaybe (keyword "funcon-term" *> colon *> pFuncons <* semiColon))
            <*> (M.fromList <$> many pKeyValues)
 where toOpts mf gen = defaultRunOptions {mfuncon_term = mf, general_opts = gen}
       pKeyValues = pBoolOpts <|> pStringOpts
        where   pBoolOpts = choice (map pKeyValue booleanOptions)
                 where pKeyValue key = (pack key,) . maybe "true" id 
                            <$ keyword key <*> optionMaybe (colon *> pBool) <* semiColon
                    
                pStringOpts = choice (map pKeyValue stringOptions)
                 where pKeyValue key = (pack key,) <$ keyword key <* colon <*> pStringValue <* semiColon

pBool :: Parser String
pBool = string "true" <|> string "false"

pStringValue :: Parser String
pStringValue = filter (not . isSpace) . concat <$> commaSep1 stringValue
    where stringValue = many1 (choice [alphaNum, char '-'])

pFunconName = many1 (choice [alphaNum, char '-'])
 
pFunconTerm :: Parser Funcons
pFunconTerm = pFuncons

pBuiltinFuncons :: Parser RunOptions
pBuiltinFuncons = (\list -> defaultRunOptions {builtin_funcons = M.fromList list}) <$> 
    many ((,) . pack <$> pFunconName <* equals <*> pFunconTerm <* semiColon)

pTestOutcomes :: Parser RunOptions
pTestOutcomes = toOptions <$> (M.union <$> pResult <*> pEntityValues)
    where pResult = mStoreResult <$> optionMaybe (id <$ keyword "result-term" <* colon 
                                        <*> pFunconTerm <* semiColon)
            where mStoreResult Nothing = M.empty
                  mStoreResult (Just f) = M.singleton "result-term" f
          pEntityValues = M.fromList <$>    
            many (((,) . pack <$> pFunconName <* colon <*> pFunconTerm <* semiColon))
          toOptions map = defaultRunOptions { expected_outcomes = map }

pInputValues :: Parser RunOptions 
pInputValues = (\list -> defaultRunOptions { given_inputs = M.fromList list}) <$>
    many (toPair <$> pFunconName <* colon <*> pFunconTerm <* semiColon) 
    where toPair nm f = case recursiveFunconValue f of 
                Just (List vs)  -> (pack nm, vs)
                _               -> error ("inputs for " ++ nm ++ " not a list")

-- simple lexer
languageDef = L.emptyDef {
                    P.identStart = lower
                ,   P.identLetter = lower <|> oneOf "-"
                ,   P.reservedNames = allOptions ++ ["result-term"]
                ,   P.reservedOpNames = [":"]
                ,   P.commentLine = "--"
                }

language = P.makeTokenParser languageDef

equals = whitespace *> char '=' <* whitespace
colon = whitespace *> char ':' <* whitespace
semiColon = whitespace *> char ';' <* whitespace

whitespace = P.whiteSpace language
comma = P.comma language
keyword = P.reserved language
braces = P.braces language
identifier = P.identifier language
stringLiteral = P.stringLiteral language
commaSep1 = P.commaSep1 language
semiSep = P.semiSep language