diff --git a/src/Cryptol/Eval.hs b/src/Cryptol/Eval.hs index ac7f84d4..535b1341 100644 --- a/src/Cryptol/Eval.hs +++ b/src/Cryptol/Eval.hs @@ -395,7 +395,7 @@ evalDecl :: EvalPrims b w i -> Eval (GenEvalEnv b w i) evalDecl renv env d = case dDefinition d of - DPrim -> bindVarDirect (dName d) (evalPrim d) env + DPrim -> return $ bindVarDirect (dName d) (evalPrim d) env DExpr e -> bindVar (dName d) (evalExpr renv e) env diff --git a/src/Cryptol/Eval/Env.hs b/src/Cryptol/Eval/Env.hs index 150cba91..1c4973e8 100644 --- a/src/Cryptol/Eval/Env.hs +++ b/src/Cryptol/Eval/Env.hs @@ -78,9 +78,9 @@ bindVar n val env = do bindVarDirect :: Name -> GenValue b w i -> GenEvalEnv b w i - -> Eval (GenEvalEnv b w i) + -> GenEvalEnv b w i bindVarDirect n val env = do - return $ env{ envVars = Map.insert n (ready val) (envVars env) } + env{ envVars = Map.insert n (ready val) (envVars env) } -- | Lookup a variable in the environment. {-# INLINE lookupVar #-} diff --git a/src/Cryptol/REPL/Command.hs b/src/Cryptol/REPL/Command.hs index 2a411296..cff5c6a8 100644 --- a/src/Cryptol/REPL/Command.hs +++ b/src/Cryptol/REPL/Command.hs @@ -59,6 +59,7 @@ import qualified Cryptol.ModuleSystem.Env as M import qualified Cryptol.Eval.Monad as E import qualified Cryptol.Eval.Value as E +import qualified Cryptol.Eval.Env as E import qualified Cryptol.Eval.Reference as R import Cryptol.Testing.Concrete import qualified Cryptol.Testing.Random as TestR @@ -316,7 +317,7 @@ qcCmd qcMode str = (val,ty) <- replEvalExpr expr EnvNum testNum <- getUser "tests" case testableType ty of - Just (sz,vss) | qcMode == QCExhaust || sz <= toInteger testNum -> do + Just (sz,tys,vss) | qcMode == QCExhaust || sz <= toInteger testNum -> do rPutStrLn "Using exhaustive testing." let f _ [] = panic "Cryptol.REPL.Command" ["Exhaustive testing ran out of test cases"] @@ -331,7 +332,7 @@ qcCmd qcMode str = , testPossible = sz , testRptProgress = ppProgress , testClrProgress = delProgress - , testRptFailure = ppFailure expr + , testRptFailure = ppFailure tys expr , testRptSuccess = do delTesting prtLn $ "passed " ++ show sz ++ " tests." @@ -341,7 +342,7 @@ qcCmd qcMode str = report <- runTests testSpec vss return [report] - Just (sz,_) -> case TestR.testableType ty of + Just (sz,tys,_) -> case TestR.testableType ty of Nothing -> raise (TypeNotTestable ty) Just gens -> do rPutStrLn "Using random testing." @@ -354,7 +355,7 @@ qcCmd qcMode str = , testPossible = sz , testRptProgress = ppProgress , testClrProgress = delProgress - , testRptFailure = ppFailure expr + , testRptFailure = ppFailure tys expr , testRptSuccess = do delTesting prtLn $ "passed " ++ show testNum ++ " tests." @@ -404,13 +405,20 @@ qcCmd qcMode str = delTesting = del (length testingMsg) delProgress = del totProgressWidth - ppFailure pexpr failure = do + ppFailure tys pexpr failure = do delTesting opts <- getPPValOpts case failure of FailFalse vs -> do let isSat = False printCounterexample isSat pexpr vs + case (tys,vs) of + ([t],[v]) -> bindItVariableVal t v + _ -> let fs = [ M.packIdent ("arg" ++ show (i::Int)) | i <- [ 1 .. ] ] + t = T.TRec (zip fs tys) + v = E.VRecord (zip fs (map return vs)) + in bindItVariableVal t v + FailError err [] -> do prtLn "ERROR" rPrint (pp err) @@ -1185,6 +1193,37 @@ bindItVariable ty expr = do `M.shadowing` M.deNames denv setDynEnv $ denv { M.deNames = nenv' } + +-- | Extend the dynamic environment with a fresh binding for "it", +-- as defined by the given value. +bindItVariableVal :: T.Type -> E.Value -> REPL () +bindItVariableVal ty val = do + freshIt <- freshName itIdent + let schema = T.Forall { T.sVars = [] + , T.sProps = [] + , T.sType = ty + } + decl = T.Decl { T.dName = freshIt + , T.dSignature = schema + , T.dDefinition = T.DPrim + , T.dPragmas = [] + , T.dInfix = False + , T.dFixity = Nothing + , T.dDoc = Nothing + } + + denv <- getDynEnv + let nenv' = M.singletonE (P.UnQual itIdent) freshIt + `M.shadowing` M.deNames denv + ndecls = T.NonRecursive decl : M.deDecls denv + neenv = E.bindVarDirect freshIt val (M.deEnv denv) + setDynEnv $ denv { M.deNames = nenv' + , M.deDecls = ndecls + , M.deEnv = neenv + } + + + -- | Creates a fresh binding of "it" to a finite sequence of -- expressions of the same type, and adds that sequence to the current -- dynamic environment diff --git a/src/Cryptol/Testing/Concrete.hs b/src/Cryptol/Testing/Concrete.hs index 4a2232c1..0e5e30a4 100644 --- a/src/Cryptol/Testing/Concrete.hs +++ b/src/Cryptol/Testing/Concrete.hs @@ -61,15 +61,16 @@ runOneTest evOpts v0 vs0 = run `X.catch` handle ] ++ map show vsdocs {- | Given a (function) type, compute all possible inputs for it. -We also return the total number of test (i.e., the length of the outer list. -} -testableType :: Type -> Maybe (Integer, [[Value]]) +We also return the types of the arguments and +the total number of test (i.e., the length of the outer list. -} +testableType :: Type -> Maybe (Integer, [Type], [[Value]]) testableType ty = case tNoUser ty of TCon (TC TCFun) [t1,t2] -> do sz <- typeSize t1 - (tot,vss) <- testableType t2 - return (sz * tot, [ v : vs | v <- typeValues t1, vs <- vss ]) - TCon (TC TCBit) [] -> return (1, [[]]) + (tot,ts,vss) <- testableType t2 + return (sz * tot, t1:ts, [ v : vs | v <- typeValues t1, vs <- vss ]) + TCon (TC TCBit) [] -> return (1, [], [[]]) _ -> Nothing {- | Given a fully-evaluated type, try to compute the number of values in it.