Make :check and :exhaust bind the counter example in it

Fixes #449

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
 
 

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 #-}

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

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. -}
+We also return the types of the arguments and
-testableType :: Type -> Maybe (Integer, [[Value]])
+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
+         (tot,ts,vss) <- testableType t2
-         return (sz * tot, [ v : vs | v <- typeValues t1, vs <- vss ])
+         return (sz * tot, t1:ts, [ v : vs | v <- typeValues t1, vs <- vss ])
-    TCon (TC TCBit) [] -> return (1, [[]])
+    TCon (TC TCBit) [] -> return (1, [], [[]])
     _ -> Nothing
 
 {- | Given a fully-evaluated type, try to compute the number of values in it.