diff --git a/cryptol/REPL/Command.hs b/cryptol/REPL/Command.hs index 5ada7a3a..7c0f035f 100644 --- a/cryptol/REPL/Command.hs +++ b/cryptol/REPL/Command.hs @@ -337,14 +337,16 @@ satCmd str = do EnvString proverName <- getUser "prover" EnvBool iteSolver <- getUser "iteSolver" EnvBool verbose <- getUser "debug" + EnvNum n <- getUser "satNum" result <- liftModuleCmd $ Cryptol.Symbolic.sat (proverName, iteSolver, verbose) (expr, schema) ppOpts <- getPPValOpts case result of Left msg -> io $ putStrLn msg Right Nothing -> io $ putStrLn "Unsatisfiable." - Right (Just vs) -> io $ print $ hsep (doc : docs) <+> text "= True" - where doc = ppPrec 3 parseExpr -- function application has precedence 3 - docs = map (pp . E.WithBase ppOpts) vs + Right (Just vs) -> do + let solutions = map (map (pp . E.WithBase ppOpts)) vs + io $ print ((ppPrec 3 parseExpr) <+> text "is satisfied by:") -- function application has precedence 3 + mapM_ (io . print) (if n < 0 then solutions else take n solutions) specializeCmd :: String -> REPL () specializeCmd str = do diff --git a/cryptol/REPL/Monad.hs b/cryptol/REPL/Monad.hs index 63817f1d..f0fbbe49 100644 --- a/cryptol/REPL/Monad.hs +++ b/cryptol/REPL/Monad.hs @@ -381,6 +381,8 @@ userOptions = mkOptionMap "display 7- or 8-bit words using ASCII notation." , OptionDescr "infLength" (EnvNum 5) checkInfLength "The number of elements to display for infinite sequences." + , OptionDescr "satNum" (EnvNum 1) (const Nothing) + "The number of solutions to display that satisfy an equation (-1 for infinity)." , OptionDescr "tests" (EnvNum 100) (const Nothing) "The number of random tests to try." , OptionDescr "prover" (EnvString "cvc4") checkProver $ diff --git a/src/Cryptol/Symbolic.hs b/src/Cryptol/Symbolic.hs index 6099fb49..5a27461a 100644 --- a/src/Cryptol/Symbolic.hs +++ b/src/Cryptol/Symbolic.hs @@ -80,7 +80,7 @@ prove (proverName, useSolverIte, verbose) (expr, schema) = protectStack useSolve SBV.ThmResult _ -> Left (show result) return (Right (solution, modEnv), []) -sat :: (String, Bool, Bool) -> (Expr, Schema) -> M.ModuleCmd (Either String (Maybe [Eval.Value])) +sat :: (String, Bool, Bool) -> (Expr, Schema) -> M.ModuleCmd (Either String (Maybe [[Eval.Value]])) sat (proverName, useSolverIte, verbose) (expr, schema) = protectStack useSolverIte $ \modEnv -> do let extDgs = allDeclGroups modEnv let prover = lookupProver proverName @@ -89,18 +89,19 @@ sat (proverName, useSolverIte, verbose) (expr, schema) = protectStack useSolverI Right ts -> do when verbose $ putStrLn "Simulating..." let env = evalDecls (emptyEnv useSolverIte) extDgs let v = evalExpr env expr - result <- SBV.satWith prover $ do + SBV.AllSatResult (_, results) <- SBV.allSatWith prover $ do args <- mapM existsFinType ts b <- return $! fromVBit (foldl fromVFun v args) when verbose $ liftIO $ putStrLn $ "Calling " ++ proverName ++ "..." return b - let solution = case result of - SBV.SatResult (SBV.Satisfiable {}) -> Right (Just vs) - where Right (_, cws) = SBV.getModel result - (vs, _) = parseValues ts cws - SBV.SatResult (SBV.Unsatisfiable {}) -> Right Nothing - SBV.SatResult _ -> Left (show result) - return (Right (solution, modEnv), []) + let solutions = case results of + (SBV.Satisfiable {} : _) -> Right (Just vs) where + vs = map (\r -> let + Right (_, cws) = SBV.getModel r + (vs, _) = parseValues ts cws + in vs) results + _ -> Right Nothing + return (Right (solutions, modEnv), []) protectStack :: Bool -> M.ModuleCmd (Either String a) -> M.ModuleCmd (Either String a) protectStack usingITE cmd modEnv = X.catchJust isOverflow (cmd modEnv) handler