{-# Language DeriveDataTypeable #-}
module Test.Speculate.Args
( Args (..)
, args
, constant
, showConstant
, foreground
, background
, getArgs
, computeMaxSemiSize
, computeMaxCondSize
, computeInstances
, types
, atoms
, compareExpr
, keepExpr
, timeout
, shouldShowEquation
, shouldShowConditionalEquation
, reallyShowConditions
, foregroundConstants
, backgroundConstants
, about
, allAbout
, prepareArgs
, module System.Console.CmdArgs.Explicit
)
where
import Test.Speculate.Expr
import Test.Speculate.Utils
import System.Console.CmdArgs.Explicit
import Test.LeanCheck ((\/))
import qualified Data.List as L (insert)
import Data.List hiding (insert)
import Data.Maybe (catMaybes)
import Data.Monoid ((<>))
import Data.Maybe
data Args = Args
{ maxSize :: Int
, maxTests :: Int
, constants :: [Expr]
, instances :: [Instances]
, maxSemiSize :: Int
, maxCondSize :: Int
, maxVars :: Int
, showConstants :: Bool
, showEquations :: Bool
, showSemiequations :: Bool
, showConditions :: Bool
, showConstantLaws :: Bool
, autoConstants :: Bool
, minTests :: Int -> Int
, maxConstants :: Maybe Int
, maxDepth :: Maybe Int
, showCounts :: Bool
, showTheory :: Bool
, showArgs :: Bool
, showHelp :: Bool
, evalTimeout :: Maybe Double
, force :: Bool
, extra :: [String]
, exclude :: [String]
, onlyTypes :: [String]
, showClassesFor :: [Int]
, showDot :: Bool
, quietDot :: Bool
}
deriving Typeable
args :: Args
args = Args
{ maxSize = 5
, maxTests = 500
, minTests = \n -> n `div` 20
, maxSemiSize = -1
, maxCondSize = -1
, maxDepth = Nothing
, instances = []
, showConstants = True
, autoConstants = False
, showArgs = True
, showTheory = False
, showEquations = True
, showSemiequations = True
, showConditions = True
, showConstantLaws = False
, showCounts = False
, showDot = False
, quietDot = False
, showClassesFor = []
, maxVars = 2
, maxConstants = Nothing
, evalTimeout = Nothing
, showHelp = False
, force = False
, extra = []
, constants = []
, exclude = []
, onlyTypes = []
}
computeMaxSemiSize :: Args -> Int
computeMaxSemiSize args
| maxSemiSize args > 0 = maxSemiSize args
| otherwise = maxSize args + maxSemiSize args
computeMaxCondSize :: Args -> Int
computeMaxCondSize args
| maxCondSize args > 0 = maxCondSize args
| otherwise = maxSize args + maxCondSize args
computeInstances :: Args -> Instances
computeInstances args = concat (instances args) ++ preludeInstances
shouldShow2 :: Args -> (Expr,Expr) -> Bool
shouldShow2 args (e1,e2) = showConstantLaws args || hasVar e1 || hasVar e2
shouldShowEquation :: Args -> (Expr,Expr) -> Bool
shouldShowEquation args (e1,e2) =
shouldShow2 args (e1,e2) && (e1 `about` fore || e2 `about` fore)
where
fore = foregroundConstants args
shouldShow3 :: Args -> (Expr,Expr,Expr) -> Bool
shouldShow3 args (e1,e2,e3) = showConstantLaws args
|| hasVar e1 || hasVar e2 || hasVar e3
shouldShowConditionalEquation :: Args -> (Expr,Expr,Expr) -> Bool
shouldShowConditionalEquation args (ce,e1,e2) = shouldShow3 args (ce,e1,e2)
&& cem ce e1 e2
&& (ce `about` fore
|| e1 `about` fore
|| e2 `about` fore)
where
cem = condEqualM (computeInstances args) (maxTests args) (minTests args (maxTests args))
fore = foregroundConstants args
keepExpr :: Args -> Expr -> Bool
keepExpr Args{maxConstants = Just n} e | length (nubConsts e) > n = False
keepExpr Args{maxDepth = Just n} e | depth e > n = False
keepExpr _ _ = True
reallyShowConditions :: Args -> Bool
reallyShowConditions args = showConditions args
&& boolTy `elem` map (finalResultTy . typ) (allConstants args)
atoms :: Args -> [[Expr]]
atoms args = [ nubSort (mapMaybe (maybeHoleOfTy is) ts)
`union` allConstants args
`union` [val True | showConds || showDot args]
`union` [val False | showConds || showDot args]
`union` (nubSort . catMaybes) [lookupComparison "==" t is | showConds, t <- ts] ]
\-/ foldr (\/) [] [lookupTiersT is t | autoConstants args, t <- ts, isListableT is t]
where
ts = types args
is = computeInstances args
showConds = reallyShowConditions args
[] \-/ [] = []
xss \-/ [] = xss
[] \-/ yss = yss
(xs:xss) \-/ (ys:yss) = xs `union` ys : xss \-/ yss
types :: Args -> [TypeRep]
types = typesInList . map typ . allConstants
foregroundConstants, backgroundConstants :: Args -> [Expr]
foregroundConstants = fst . partitionByMarkers foreground background . constants
backgroundConstants = snd . partitionByMarkers foreground background . constants
allConstants :: Args -> [Expr]
allConstants args = discard (\c -> any (c `isConstantNamed`) (exclude args))
$ discard (\e -> e == foreground || e == background)
$ constants args
allAbout :: Expr -> [Expr] -> Bool
e `allAbout` es = nubConsts e `areAll` (`elem` es)
about :: Expr -> [Expr] -> Bool
e `about` es = nubConsts e `areAny` (`elem` es)
timeout :: Args -> Bool -> Bool
timeout Args{evalTimeout = Nothing} = id
timeout Args{evalTimeout = Just t} = timeoutToFalse t
compareExpr :: Args -> Expr -> Expr -> Ordering
compareExpr args = compareComplexity <> lexicompareBy cmp
where
e1 `cmp` e2 | arity e1 == 0 && arity e2 /= 0 = LT
e1 `cmp` e2 | arity e1 /= 0 && arity e2 == 0 = GT
e1 `cmp` e2 = compareIndex (exprPair:concat (atoms args)) e1 e2 <> e1 `compare` e2
exprPair = head . unfoldApp $ foldPair (val (), val ())
constant :: Typeable a => String -> a -> Expr
constant = value
showConstant :: (Typeable a, Show a) => a -> Expr
showConstant = val
foreground :: Expr
foreground = constant "foreground" (undefined :: Args)
background :: Expr
background = constant "background" (undefined :: Args)
prepareArgs :: Args -> Mode Args
prepareArgs args =
mode "speculate" args "" (flagArg (\s a -> Right a {extra = s:extra a}) "")
[ "ssize" --= \s a -> a {maxSize = read s}
, "ttests" --= \s a -> a {maxTests = read s}
, "mmin-tests" --= \s a -> a {minTests = parseMinTests s}
, "zsemisize" --= \s a -> a {maxSemiSize = read s}
, "xcondsize" --= \s a -> a {maxCondSize = read s}
, "Aconstants" --. \a -> a {showConstants = False}
, "Uauto-constants" --. \a -> a {autoConstants = True}
, "Ohide-args" --. \a -> a {showArgs = False}
, "Ttheory" --. \a -> a {showTheory = True}
, "Eno-equations" --. \a -> a {showEquations = False}
, "Sno-semiequations" --. \a -> a {showSemiequations = False}
, "Cno-sideconditions" --. \a -> a {showConditions = False}
, "0no-constant-laws" --. \a -> a {showConstantLaws = True}
, "rclass-reps-for" --= \s a -> a {showClassesFor = read s `L.insert` showClassesFor a}
, "vvars" --= \s a -> a {maxVars = read s}
, "cmax-constants" --= \s a -> a {maxConstants = Just $ read s}
, "eeval-timeout" --= \s a -> a {evalTimeout = Just $ read s}
, "ddepth" --= \s a -> a {maxDepth = Just $ read s}
, " counts" --. \a -> a {showCounts = True}
, "gsemi-digraph" --. \a -> a {showDot = True
,quietDot = False
,showConstants = False
,showEquations = False
,showSemiequations = False
,showConditions = False
,showArgs = False}
, "Dquiet-dot" --. \a -> a {showDot = True
,quietDot = True
,showConstants = False
,showEquations = False
,showSemiequations = False
,showConditions = False
,showArgs = False}
, " only-types" --= \s a -> a {onlyTypes = onlyTypes a ++ splitAtCommas s}
, "fforce" --. \a -> a {force = True}
, "hhelp" --. \a -> a {showHelp = True}
, " exclude" --= \s a -> a {exclude = exclude a ++ splitAtCommas s}
, "aall-foreground" --. \a -> a {constants = discard (== background) (constants a)}
]
where
(short:long) --= fun = flagReq (filter (/= " ") [[short],long]) ((Right .) . fun) "X" ""
_ --= _ = error "(--=): first argument can't be \"\""
(short:long) --. fun = flagNone (filter (/= " ") [[short],long]) fun ""
_ --. _ = error "(--.): first argument can't be \"\""
parseMinTests :: String -> Int -> Int
parseMinTests s | last s == '%' = \x -> read (init s) * x `div` 100
| otherwise = const (read s)
getArgs :: Args -> IO Args
getArgs = processArgs . prepareArgs