diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,33 @@ * Hackage: * GitHub: +### Version 14.1, 2026-05-04 + + * [BACKWARDS COMPATIBILITY] Removed `tpRibbon`. The ribbon length for TP proof + output is now auto-computed from the proof structure via a lightweight dry-run + pass. Users no longer need to manually set it. + + * New TP combinators `whenDryRun` and `unlessDryRun` allow user code to guard + actions (e.g., proof tree printing) that should only run during the real pass of a TP + based proof. + + * TP `pCase` now supports nested `case` expressions as proof case-splits, + mirroring how `sCase` treats nested `case` as symbolic cases. + + * Consolidated internal solver IPC timeouts into named constants. + Set the environment variable `SBV_COMM_TIMEOUT_FACTOR` to scale them (e.g., `2` to double). + + * Better handling of logic-strings, accommodating solver differences. Thanks to Ryan Scott for the report. + + * Fixed a bug in fpRemH, which calculates the floating point reminder for concrete values. The result + was rounded twice, which is against the specification. Thanks to Ryan Scott for the report and the fix. + + * Simplify how floating-point literals are printed. The older method worked for Z3/CVC5, but not for Bitwuzla. + Thanks to Ryan Scott for the report and the fix. + + * Fix the definition of sRealToSIntegerTruncate to do proper truncation. Thanks to Ryan Scott for the + report and the fix. + ### Version 14.0, 2026-04-01 * [BACKWARDS COMPATIBILITY] The most important change in this release is how SBV treats @@ -309,7 +336,7 @@ variable or an underscore.) Symbolic-boolean guards allow for concise expressions. This construct makes symbolic programming with ADTs easier. - * Added examples under Documentation.SBV.Examples.ADT, demonstrating the use of basic ADTs and a case study + * Added examples under Documentation.SBV.Examples.ADT, demonstrating the use of basic ADTs and a case study of modeling type-checking constraints. * Added Documentation.SBV.Examples.TP.Peano, modeling peano numbers using an ADT and demonstrating many proofs. @@ -438,7 +465,7 @@ methods/tactics on top of knuckle-dragger provided facilities. ### Version 11.6, 2025-05-10 - + * Make SBV compile cleanly with GHC 9.8.4. This is really as far back a GHC you should be using, unless you can't use anything newer. diff --git a/Data/SBV.hs b/Data/SBV.hs --- a/Data/SBV.hs +++ b/Data/SBV.hs @@ -486,6 +486,8 @@ import Control.Monad (unless) import Control.Monad.Trans (MonadIO) +import qualified Data.Text as T + import Data.SBV.Core.AlgReals import Data.SBV.Core.Data hiding (free, free_, mkFreeVars, output, symbolic, symbolics, mkSymVal, @@ -905,25 +907,25 @@ allSatPartition "p2" $ y .>= 0 :} Solution #1: - x = 0 :: Integer - y = -1 :: Integer - p1 = True :: Bool - p2 = False :: Bool -Solution #2: x = -1 :: Integer y = 0 :: Integer p1 = False :: Bool p2 = True :: Bool +Solution #2: + x = 0 :: Integer + y = 0 :: Integer + p1 = True :: Bool + p2 = True :: Bool Solution #3: + x = 0 :: Integer + y = -1 :: Integer + p1 = True :: Bool + p2 = False :: Bool +Solution #4: x = -1 :: Integer y = -1 :: Integer p1 = False :: Bool p2 = False :: Bool -Solution #4: - x = 0 :: Integer - y = 0 :: Integer - p1 = True :: Bool - p2 = True :: Bool Found 4 different solutions. Without the call to 'allSatPartition' the above example, 'allSat' would return all possible combinations of @x@ and @y@ subject to the constraints. (Since we have none here, @@ -1742,7 +1744,7 @@ sa <- sbvToSV st a sb <- sbvToSV st b - newExpr st KBool $ SBVApp (Uninterpreted nm) [sa, sb] + newExpr st KBool $ SBVApp (Uninterpreted (T.pack nm)) [sa, sb] -- | Check if the given relation satisfies the required axioms checkSpecialRelation :: forall a. SymVal a => SpecialRelOp -> Relation a -> SBool @@ -1768,8 +1770,8 @@ uop <- newUninterpreted st (UIGiven nm) Nothing (SBVType [ka, ka, KBool]) (UINone True) let nm' = case uop of - Uninterpreted s -> s - _ -> error "Data.SBV: Impossible happened: checkSpecialRelation received: " ++ show op + Uninterpreted s -> T.unpack s + _ -> error $ "Data.SBV: Impossible happened: checkSpecialRelation received: " ++ show op -- Add to the end so if we get incremental ones the order doesn't change for old ones! modifyIORef' (rProgInfo st) (\u -> u{progSpecialRels = curSpecialRels ++ [iop]}) @@ -1851,6 +1853,6 @@ create = freshVar_ project = getValue - embed = return . literal + embed = pure . literal {- HLint ignore module "Use import/export shortcut" -} diff --git a/Data/SBV/Client.hs b/Data/SBV/Client.hs --- a/Data/SBV/Client.hs +++ b/Data/SBV/Client.hs @@ -24,7 +24,7 @@ {-# LANGUAGE FlexibleInstances #-} #endif -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Client ( sbvCheckSolverInstallation @@ -49,9 +49,7 @@ import Data.Ratio import qualified "template-haskell" Language.Haskell.TH as TH -#if MIN_VERSION_template_haskell(2,18,0) import qualified "template-haskell" Language.Haskell.TH.Syntax as TH -#endif import Language.Haskell.TH.ExpandSyns as TH @@ -71,11 +69,11 @@ -- | Check whether the given solver is installed and is ready to go. This call does a -- simple call to the solver to ensure all is well. sbvCheckSolverInstallation :: SMTConfig -> IO Bool -sbvCheckSolverInstallation cfg = check `C.catch` (\(_ :: C.SomeException) -> return False) +sbvCheckSolverInstallation cfg = check `C.catch` (\(_ :: C.SomeException) -> pure False) where check = do ThmResult r <- proveWith cfg $ \x -> sNot (sNot x) .== (x :: SBool) case r of - Unsatisfiable{} -> return True - _ -> return False + Unsatisfiable{} -> pure True + _ -> pure False -- | The default configs corresponding to supported SMT solvers defaultSolverConfig :: Solver -> SMTConfig @@ -154,22 +152,14 @@ -- | Add document to a generated declaration for the declaration addDeclDocs :: (TH.Name, String) -> [(TH.Name, String)] -> TH.Q () -#if MIN_VERSION_template_haskell(2,18,0) addDeclDocs (tnm, ts) cnms = do add True (tnm, ts) mapM_ (add False) cnms where add True (cnm, cs) = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc cnm) $ "Symbolic version of the type t'" ++ cs ++ "'." add False (cnm, cs) = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc cnm) $ "Symbolic version of the constructor v'" ++ cs ++ "'." -#else -addDeclDocs _ _ = pure () -#endif -- | Add document to a generated function addDoc :: String -> TH.Name -> TH.Q () -#if MIN_VERSION_template_haskell(2,18,0) addDoc what tnm = TH.addModFinalizer $ TH.putDoc (TH.DeclDoc tnm) what -#else -addDoc _ _ = pure () -#endif -- | Symbolic version of a type mkSBV :: TH.Type -> TH.Type @@ -290,7 +280,7 @@ concretize (TH.AppT l arg) = TH.AppT (concretize l) (concretize arg) concretize r = r - end <- TH.noBindS [| return () |] + end <- TH.noBindS [| pure () |] pure $ TH.DoE Nothing $ [TH.NoBindS (TH.AppE (TH.AppE (TH.VarE 'registerKind) (TH.VarE st)) (TH.AppE (TH.VarE 'kindOf) (TH.AppTypeE (TH.ConE 'Proxy) (concretize t)))) diff --git a/Data/SBV/Compilers/C.hs b/Data/SBV/Compilers/C.hs --- a/Data/SBV/Compilers/C.hs +++ b/Data/SBV/Compilers/C.hs @@ -60,11 +60,11 @@ compileToC :: Maybe FilePath -> String -> SBVCodeGen a -> IO a compileToC mbDirName nm f = do (retVal, cfg, bundle) <- compileToC' nm f renderCgPgmBundle mbDirName (cfg, bundle) - return retVal + pure retVal -- | Lower level version of 'compileToC', producing a t'CgPgmBundle' compileToC' :: String -> SBVCodeGen a -> IO (a, CgConfig, CgPgmBundle) -compileToC' nm f = do rands <- randoms `fmap` newStdGen +compileToC' nm f = do rands <- randoms <$> newStdGen codeGen SBVToC (defaultCgConfig { cgDriverVals = rands }) nm f -- | Create code to generate a library archive (.a) from given symbolic functions. Useful when generating code @@ -80,13 +80,13 @@ compileToCLib :: Maybe FilePath -> String -> [(String, SBVCodeGen a)] -> IO [a] compileToCLib mbDirName libName comps = do (retVal, cfg, pgm) <- compileToCLib' libName comps renderCgPgmBundle mbDirName (cfg, pgm) - return retVal + pure retVal -- | Lower level version of 'compileToCLib', producing a t'CgPgmBundle' compileToCLib' :: String -> [(String, SBVCodeGen a)] -> IO ([a], CgConfig, CgPgmBundle) compileToCLib' libName comps = do resCfgBundles <- mapM (uncurry compileToC') comps let (finalCfg, finalPgm) = mergeToLib libName [(c, b) | (_, c, b) <- resCfgBundles] - return ([r | (r, _, _) <- resCfgBundles], finalCfg, finalPgm) + pure ([r | (r, _, _) <- resCfgBundles], finalCfg, finalPgm) --------------------------------------------------------------------------- -- * Implementation @@ -609,7 +609,7 @@ genAssert (msg, cs, sv) = (getNodeId sv, doc) where doc = text "/* ASSERTION:" <+> text msg - $$ maybe empty (vcat . map text) (locInfo (getCallStack `fmap` cs)) + $$ maybe empty (vcat . map text) (locInfo (getCallStack <$> cs)) $$ text " */" $$ text "if" P.<> parens (showSV cfg consts sv) $$ text "{" @@ -764,8 +764,8 @@ p (PseudoBoolean pb) as = handlePB pb as p (OverflowOp o) _ = tbd $ "Overflow operations" ++ show o p (KindCast _ to) [a] = parens (text (show to)) <+> a - p (Uninterpreted s) [] = text "/* Uninterpreted constant */" <+> text s - p (Uninterpreted s) as = text "/* Uninterpreted function */" <+> text s P.<> parens (fsep (punctuate comma as)) + p (Uninterpreted s) [] = text "/* Uninterpreted constant */" <+> text (T.unpack s) + p (Uninterpreted s) as = text "/* Uninterpreted function */" <+> text (T.unpack s) P.<> parens (fsep (punctuate comma as)) p (Extract i j) [a] = extract i j (hd "Extract" opArgs) a p Join [a, b] = join (let (s1 : s2 : _) = opArgs in (s1, s2, a, b)) p (Rol i) [a] = rotate True i a (hd "Rol" opArgs) diff --git a/Data/SBV/Compilers/CodeGen.hs b/Data/SBV/Compilers/CodeGen.hs --- a/Data/SBV/Compilers/CodeGen.hs +++ b/Data/SBV/Compilers/CodeGen.hs @@ -9,7 +9,6 @@ -- Code generation utilities ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -58,10 +57,6 @@ import Data.SBV.Provers.Prover(defaultSMTCfg) -#if MIN_VERSION_base(4,11,0) -import Control.Monad.Fail as Fail -#endif - -- | Abstract over code generation for different languages class CgTarget a where targetName :: a -> String @@ -126,9 +121,7 @@ newtype SBVCodeGen a = SBVCodeGen (StateT CgState Symbolic a) deriving ( Applicative, Functor, Monad, MonadIO, MonadState CgState , MonadSymbolic -#if MIN_VERSION_base(4,11,0) - , Fail.MonadFail -#endif + , MonadFail ) -- | Reach into symbolic monad from code-generation @@ -220,7 +213,7 @@ svCgInput k nm = do r <- symbolicEnv >>= liftIO . svMkSymVar (NonQueryVar (Just ALL)) k Nothing sv <- svToSymSV r modify' (\s -> s { cgInputs = (nm, CgAtomic sv) : cgInputs s }) - return r + pure r -- | Creates an array input in the generated code. svCgInputArr :: Kind -> Int -> String -> SBVCodeGen [SVal] @@ -229,7 +222,7 @@ | True = do rs <- symbolicEnv >>= liftIO . replicateM sz . svMkSymVar (NonQueryVar (Just ALL)) k Nothing sws <- mapM svToSymSV rs modify' (\s -> s { cgInputs = (nm, CgArray sws) : cgInputs s }) - return rs + pure rs -- | Creates an atomic output in the generated code. svCgOutput :: String -> SVal -> SBVCodeGen () @@ -266,7 +259,7 @@ cgInput nm = do r <- free_ sv <- sbvToSymSV r modify' (\s -> s { cgInputs = (nm, CgAtomic sv) : cgInputs s }) - return r + pure r -- | Creates an array input in the generated code. cgInputArr :: SymVal a => Int -> String -> SBVCodeGen [SBV a] @@ -275,7 +268,7 @@ | True = do rs <- mapM (const free_) [1..sz] sws <- mapM sbvToSymSV rs modify' (\s -> s { cgInputs = (nm, CgArray sws) : cgInputs s }) - return rs + pure rs -- | Creates an atomic output in the generated code. cgOutput :: String -> SBV a -> SBVCodeGen () @@ -347,7 +340,7 @@ unless (null dupNames) $ error $ "SBV.codeGen: " ++ show nm ++ " has following argument names duplicated: " ++ unwords dupNames - return (retVal, cgFinalConfig st, translate l (cgFinalConfig st) nm st res) + pure (retVal, cgFinalConfig st, translate l (cgFinalConfig st) nm st res) -- | Render a code-gen bundle to a directory or to stdout renderCgPgmBundle :: Maybe FilePath -> (CgConfig, CgPgmBundle) -> IO () @@ -361,14 +354,14 @@ dups <- filterM (\fn -> doesFileExist (dirName fn)) (map fst files) goOn <- case (overWrite, dups) of - (True, _) -> return True - (_, []) -> return True + (True, _) -> pure True + (_, []) -> pure True _ -> do putStrLn $ "Code generation would overwrite the following " ++ (if length dups == 1 then "file:" else "files:") mapM_ (\fn -> putStrLn ('\t' : fn)) dups putStr "Continue? [yn] " hFlush stdout resp <- getLine - return $ map toLower resp `isPrefixOf` "yes" + pure $ map toLower resp `isPrefixOf` "yes" if goOn then do mapM_ renderFile files unless overWrite $ putStrLn "Done." diff --git a/Data/SBV/Control/BaseIO.hs b/Data/SBV/Control/BaseIO.hs --- a/Data/SBV/Control/BaseIO.hs +++ b/Data/SBV/Control/BaseIO.hs @@ -21,6 +21,8 @@ import Data.SBV.Core.Data (Symbolic, SymVal, SBool, SBV, SBVType) import Data.SBV.Core.Symbolic (Query, QueryContext, QueryState, State, SMTModel, SMTResult, SV, Name) +import Data.Text (Text) + import qualified Data.SBV.Control.Query as Trans import qualified Data.SBV.Control.Utils as Trans @@ -401,20 +403,20 @@ -- file redirection is given, the output will go to the file. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.queryDebug' -queryDebug :: [String] -> Query () +queryDebug :: [Text] -> Query () queryDebug = Trans.queryDebug -- | Send a string to the solver, and return the response -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.ask' -ask :: String -> Query String +ask :: Text -> Query String ask = Trans.ask -- | Send a string to the solver. If the first argument is 'True', we will require -- a "success" response as well. Otherwise, we'll fire and forget. -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.send' -send :: Bool -> String -> Query () +send :: Bool -> Text -> Query () send = Trans.send -- | Retrieve a responses from the solver until it produces a synchronization tag. We make the tag @@ -506,7 +508,7 @@ -- | Bail out if we don't get what we expected -- -- NB. For a version which generalizes over the underlying monad, see 'Data.SBV.Trans.Control.unexpected' -unexpected :: String -> String -> String -> Maybe [String] -> String -> Maybe [String] -> Query a +unexpected :: String -> Text -> String -> Maybe [String] -> String -> Maybe [String] -> Query a unexpected = Trans.unexpected -- | Execute a query. diff --git a/Data/SBV/Control/Query.hs b/Data/SBV/Control/Query.hs --- a/Data/SBV/Control/Query.hs +++ b/Data/SBV/Control/Query.hs @@ -11,9 +11,10 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Control.Query ( send, ask, retrieveResponse @@ -54,7 +55,7 @@ import Data.SBV.Control.Types import Data.SBV.Control.Utils -import Data.SBV.Utils.Lib (unBar) +import Data.SBV.Utils.Lib (showText, unBar) import Data.SBV.Utils.PrettyNum (showNegativeNumber) -- | An Assignment of a model binding @@ -79,10 +80,10 @@ serialize :: Bool -> SExpr -> String serialize removeQuotes = go where go (ECon s) = if removeQuotes then unQuote s else s - go (ENum (i, _, _)) = showNegativeNumber i - go (EReal r) = showNegativeNumber r - go (EFloat f) = showNegativeNumber f - go (EDouble d) = showNegativeNumber d + go (ENum (i, _, _)) = T.unpack (showNegativeNumber i) + go (EReal r) = T.unpack (showNegativeNumber r) + go (EFloat f) = T.unpack (showNegativeNumber f) + go (EDouble d) = T.unpack (showNegativeNumber d) go (EFloatingPoint f) = show f go (EApp [x]) = go x go (EApp ss) = "(" ++ unwords (map go ss) ++ ")" @@ -90,7 +91,7 @@ -- | Generalization of 'Data.SBV.Control.getInfo' getInfo :: (MonadIO m, MonadQuery m) => SMTInfoFlag -> m SMTInfoResponse getInfo flag = do - let cmd = "(get-info " ++ show flag ++ ")" + let cmd = "(get-info " <> showText flag <> ")" bad = unexpected "getInfo" cmd "a valid get-info response" Nothing isAllStatistics AllStatistics = True @@ -112,17 +113,17 @@ parse r bad $ \pe -> if isAllStat - then return $ Resp_AllStatistics $ grabAllStats pe + then pure $ Resp_AllStatistics $ grabAllStats pe else case pe of - ECon "unsupported" -> return Resp_Unsupported - EApp [ECon ":assertion-stack-levels", ENum (i, _, _)] -> return $ Resp_AssertionStackLevels i - EApp (ECon ":authors" : ns) -> return $ Resp_Authors (map render ns) - EApp [ECon ":error-behavior", ECon "immediate-exit"] -> return $ Resp_Error ErrorImmediateExit - EApp [ECon ":error-behavior", ECon "continued-execution"] -> return $ Resp_Error ErrorContinuedExecution - EApp (ECon ":name" : o) -> return $ Resp_Name (render (EApp o)) - EApp (ECon ":reason-unknown" : o) -> return $ Resp_ReasonUnknown (unk o) - EApp (ECon ":version" : o) -> return $ Resp_Version (render (EApp o)) - EApp (ECon s : o) -> return $ Resp_InfoKeyword s (map render o) + ECon "unsupported" -> pure Resp_Unsupported + EApp [ECon ":assertion-stack-levels", ENum (i, _, _)] -> pure $ Resp_AssertionStackLevels i + EApp (ECon ":authors" : ns) -> pure $ Resp_Authors (map render ns) + EApp [ECon ":error-behavior", ECon "immediate-exit"] -> pure $ Resp_Error ErrorImmediateExit + EApp [ECon ":error-behavior", ECon "continued-execution"] -> pure $ Resp_Error ErrorContinuedExecution + EApp (ECon ":name" : o) -> pure $ Resp_Name (render (EApp o)) + EApp (ECon ":reason-unknown" : o) -> pure $ Resp_ReasonUnknown (unk o) + EApp (ECon ":version" : o) -> pure $ Resp_Version (render (EApp o)) + EApp (ECon s : o) -> pure $ Resp_InfoKeyword s (map render o) _ -> bad r Nothing where render = serialize True @@ -160,33 +161,33 @@ SetInfo{} -> error "Data.SBV.Query: SMTLib does not allow querying value of meta-info!" where askFor sbvName smtLibName continue = do - let cmd = "(get-option " ++ smtLibName ++ ")" + let cmd = "(get-option " <> T.pack smtLibName <> ")" bad = unexpected ("getOption " ++ sbvName) cmd "a valid option value" Nothing r <- ask cmd - parse r bad $ \case ECon "unsupported" -> return Nothing + parse r bad $ \case ECon "unsupported" -> pure Nothing e -> continue e (bad r) - string c (ECon s) _ = return $ Just $ c s + string c (ECon s) _ = pure $ Just $ c s string _ e k = k $ Just ["Expected string, but got: " ++ show (serialize False e)] - bool c (ENum (0, _, True)) _ = return $ Just $ c False - bool c (ENum (1, _, True)) _ = return $ Just $ c True + bool c (ENum (0, _, True)) _ = pure $ Just $ c False + bool c (ENum (1, _, True)) _ = pure $ Just $ c True bool _ e k = k $ Just ["Expected boolean, but got: " ++ show (serialize False e)] - integer c (ENum (i, _, _)) _ = return $ Just $ c i + integer c (ENum (i, _, _)) _ = pure $ Just $ c i integer _ e k = k $ Just ["Expected integer, but got: " ++ show (serialize False e)] -- free format, really - stringList c e _ = return $ Just $ c $ stringsOf e + stringList c e _ = pure $ Just $ c $ stringsOf e -- | Generalization of 'Data.SBV.Control.getUnknownReason' getUnknownReason :: (MonadIO m, MonadQuery m) => m SMTReasonUnknown getUnknownReason = do ru <- getInfo ReasonUnknown case ru of - Resp_Unsupported -> return $ UnknownOther "Solver responded: Unsupported." - Resp_ReasonUnknown r -> return r + Resp_Unsupported -> pure $ UnknownOther "Solver responded: Unsupported." + Resp_ReasonUnknown r -> pure r -- Shouldn't happen, but just in case: _ -> error $ "Unexpected reason value received: " ++ show ru @@ -195,8 +196,8 @@ ensureSat = do cfg <- getConfig cs <- checkSatUsing $ satCmd cfg case cs of - Sat -> return () - DSat{} -> return () + Sat -> pure () + DSat{} -> pure () Unk -> do s <- getUnknownReason error $ unlines [ "" , "*** Data.SBV.ensureSat: Solver reported Unknown!" @@ -232,7 +233,7 @@ Unk -> Unknown cfg <$> getUnknownReason where getModelWithObjectives = do objectiveValues <- getObjectiveValues m <- getModel - return m {modelObjectives = objectiveValues} + pure m {modelObjectives = objectiveValues} -- | Generalization of 'Data.SBV.Control.getIndependentOptResults' getIndependentOptResults :: forall m. (MonadIO m, MonadQuery m) => [String] -> m [(String, SMTResult)] @@ -240,44 +241,44 @@ cs <- checkSat case cs of - Unsat -> getUnsatCoreIfRequested >>= \mbUC -> return [(nm, Unsatisfiable cfg mbUC) | nm <- objNames] + Unsat -> getUnsatCoreIfRequested >>= \mbUC -> pure [(nm, Unsatisfiable cfg mbUC) | nm <- objNames] Sat -> continue (classifyModel cfg) DSat{} -> continue (classifyModel cfg) Unk -> do ur <- Unknown cfg <$> getUnknownReason - return [(nm, ur) | nm <- objNames] + pure [(nm, ur) | nm <- objNames] where continue classify = do objectiveValues <- getObjectiveValues nms <- zipWithM getIndependentResult [0..] objNames - return [(n, classify (m {modelObjectives = objectiveValues})) | (n, m) <- nms] + pure [(n, classify (m {modelObjectives = objectiveValues})) | (n, m) <- nms] getIndependentResult :: Int -> String -> m (String, SMTModel) getIndependentResult i s = do m <- getModelAtIndex (Just i) - return (s, m) + pure (s, m) -- | Generalization of 'Data.SBV.Control.getParetoOptResults' getParetoOptResults :: (MonadIO m, MonadQuery m) => Maybe Int -> m (Bool, [SMTResult]) getParetoOptResults (Just i) - | i <= 0 = return (True, []) + | i <= 0 = pure (True, []) getParetoOptResults mbN = do cfg <- getConfig cs <- checkSat case cs of - Unsat -> return (False, []) + Unsat -> pure (False, []) Sat -> continue (classifyModel cfg) DSat{} -> continue (classifyModel cfg) Unk -> do ur <- getUnknownReason - return (False, [ProofError cfg [show ur] Nothing]) + pure (False, [ProofError cfg [show ur] Nothing]) where continue classify = do m <- getModel (limReached, fronts) <- getParetoFronts (subtract 1 <$> mbN) [m] - return (limReached, reverse (map classify fronts)) + pure (limReached, reverse (map classify fronts)) getParetoFronts :: (MonadIO m, MonadQuery m) => Maybe Int -> [SMTModel] -> m (Bool, [SMTModel]) - getParetoFronts (Just i) sofar | i <= 0 = return (True, sofar) + getParetoFronts (Just i) sofar | i <= 0 = pure (True, sofar) getParetoFronts mbi sofar = do cs <- checkSat let more = getModel >>= \m -> getParetoFronts (subtract 1 <$> mbi) (m : sofar) case cs of - Unsat -> return (False, sofar) + Unsat -> pure (False, sofar) Sat -> more DSat{} -> more Unk -> more @@ -295,14 +296,14 @@ checkSatAssumingHelper getAssumptions sBools = do -- sigh.. SMT-Lib requires the values to be literals only. So, create proxies. let mkAssumption st = do swsOriginal <- mapM (\sb -> do sv <- sbvToSV st sb - return (sv, sb)) sBools + pure (sv, sb)) sBools -- drop duplicates and trues let swbs = [p | p@(sv, _) <- nubBy ((==) `on` fst) swsOriginal, sv /= trueSV] -- get a unique proxy name for each uniqueSWBs <- mapM (\(sv, sb) -> do unique <- incrementInternalCounter st - return (sv, (unique, sb))) swbs + pure (sv, (unique, sb))) swbs let translate (sv, (unique, sb)) = (nm, decls, (proxy, sb)) where nm = show sv @@ -311,13 +312,13 @@ , "(assert (= " ++ proxy ++ " " ++ nm ++ "))" ] - return $ map translate uniqueSWBs + pure $ map translate uniqueSWBs assumptions <- inNewContext mkAssumption let (origNames, declss, proxyMap) = unzip3 assumptions - let cmd = "(check-sat-assuming (" ++ unwords (map fst proxyMap) ++ "))" + let cmd = "(check-sat-assuming (" <> T.pack (unwords (map fst proxyMap)) <> "))" bad = unexpected "checkSatAssuming" cmd "one of sat/unsat/unknown" $ Just [ "Make sure you use:" , "" @@ -326,17 +327,17 @@ , "to tell the solver to produce unsat assumptions." ] - mapM_ (send True) $ concat declss + mapM_ (send True . T.pack) $ concat declss r <- ask cmd let grabUnsat | getAssumptions = do as <- getUnsatAssumptions origNames proxyMap - return (Unsat, Just as) - | True = return (Unsat, Nothing) + pure (Unsat, Just as) + | True = pure (Unsat, Nothing) - parse r bad $ \case ECon "sat" -> return (Sat, Nothing) + parse r bad $ \case ECon "sat" -> pure (Sat, Nothing) ECon "unsat" -> grabUnsat - ECon "unknown" -> return (Unk, Nothing) + ECon "unknown" -> pure (Unk, Nothing) _ -> bad r Nothing -- | Generalization of 'Data.SBV.Control.getAssertionStackDepth' @@ -352,23 +353,23 @@ let inits = [ "table" ++ show i ++ "_initializer" | i <- [0 .. tCount - 1]] case inits of - [] -> return () -- Nothing to do - [x] -> send True $ "(assert " ++ x ++ ")" - xs -> send True $ "(assert (and " ++ unwords xs ++ "))" + [] -> pure () -- Nothing to do + [x] -> send True $ "(assert " <> T.pack x <> ")" + xs -> send True $ "(assert (and " <> T.pack (unwords xs) <> "))" -- | Generalization of 'Data.SBV.Control.inNewAssertionStack' inNewAssertionStack :: (MonadIO m, MonadQuery m) => m a -> m a inNewAssertionStack q = do push 1 r <- q pop 1 - return r + pure r -- | Generalization of 'Data.SBV.Control.push' push :: (MonadIO m, MonadQuery m) => Int -> m () push i | i <= 0 = error $ "Data.SBV: push requires a strictly positive level argument, received: " ++ show i | True = do depth <- getAssertionStackDepth - send True $ "(push " ++ show i ++ ")" + send True $ "(push " <> showText i <> ")" modifyQueryState $ \s -> s{queryAssertionStackDepth = depth + i} -- | Generalization of 'Data.SBV.Control.pop' @@ -386,7 +387,7 @@ , "***" , "*** Request this as a feature for the underlying solver!" ] - else do send True $ "(pop " ++ show i ++ ")" + else do send True $ "(pop " <> showText i <> ")" restoreTablesAndArrays modifyQueryState $ \s -> s{queryAssertionStackDepth = depth - i} where shl 1 = "one level" @@ -398,7 +399,7 @@ go cfg (cases ++ [("Coverage", sNot (sOr (map snd cases)))]) where msg = when printCases . io . putStrLn - go _ [] = return Nothing + go _ [] = pure Nothing go cfg ((n,c):ncs) = do let notify s = msg $ "Case " ++ n ++ ": " ++ s notify "Starting" @@ -410,15 +411,15 @@ Sat -> do notify "Satisfiable" res <- Satisfiable cfg <$> getModel - return $ Just (n, res) + pure $ Just (n, res) DSat mbP -> do notify $ "Delta satisfiable" ++ maybe "" (" (precision: " ++) mbP res <- DeltaSat cfg mbP <$> getModel - return $ Just (n, res) + pure $ Just (n, res) Unk -> do notify "Unknown" res <- Unknown cfg <$> getUnknownReason - return $ Just (n, res) + pure $ Just (n, res) -- | Generalization of 'Data.SBV.Control.resetAssertions' resetAssertions :: (MonadIO m, MonadQuery m) => m () @@ -430,7 +431,7 @@ -- | Generalization of 'Data.SBV.Control.echo' echo :: (MonadIO m, MonadQuery m) => String -> m () -echo s = do let cmd = "(echo \"" ++ concatMap sanitize s ++ "\")" +echo s = do let cmd = "(echo \"" <> T.pack (concatMap sanitize s) <> "\")" -- we send the command, but otherwise ignore the response -- note that 'send True/False' would be incorrect here. 'send True' would @@ -439,7 +440,7 @@ -- and forgets about it immediately. _ <- ask cmd - return () + pure () where sanitize '"' = "\"\"" -- quotes need to be duplicated sanitize c = [c] @@ -451,7 +452,7 @@ -- | Generalization of 'Data.SBV.Control.getUnsatCore' getUnsatCore :: (MonadIO m, MonadQuery m) => m [String] getUnsatCore = do - let cmd = "(get-unsat-core)" + let cmd = "(get-unsat-core)" :: T.Text bad = unexpected "getUnsatCore" cmd "an unsat-core response" $ Just [ "Make sure you use:" , "" @@ -473,7 +474,7 @@ r <- ask cmd parse r bad $ \case - EApp es | Just xs <- mapM fromECon es -> return $ map unBar xs + EApp es | Just xs <- mapM fromECon es -> pure $ map unBar xs _ -> bad r Nothing -- | Retrieve the unsat core if it was asked for in the configuration @@ -482,12 +483,12 @@ cfg <- getConfig if or [b | ProduceUnsatCores b <- solverSetOptions cfg] then Just <$> getUnsatCore - else return Nothing + else pure Nothing -- | Generalization of 'Data.SBV.Control.getProof' getProof :: (MonadIO m, MonadQuery m) => m String getProof = do - let cmd = "(get-proof)" + let cmd = "(get-proof)" :: T.Text bad = unexpected "getProof" cmd "a get-proof response" $ Just [ "Make sure you use:" , "" @@ -502,7 +503,7 @@ -- we only care about the fact that we can parse the output, so the -- result of parsing is ignored. - parse r bad $ \_ -> return r + parse r bad $ \_ -> pure r -- | Generalization of 'Data.SBV.Control.getInterpolantMathSAT'. Use this version with MathSAT. getInterpolantMathSAT :: (MonadIO m, MonadQuery m) => [String] -> m String @@ -511,7 +512,7 @@ = error "SBV.getInterpolantMathSAT requires at least one marked constraint, received none!" | True = do let bar s = '|' : s ++ "|" - cmd = "(get-interpolant (" ++ unwords (map bar fs) ++ "))" + cmd = "(get-interpolant (" <> T.pack (unwords (map bar fs)) <> "))" bad = unexpected "getInterpolant" cmd "a get-interpolant response" $ Just [ "Make sure you use:" , "" @@ -524,29 +525,29 @@ r <- ask cmd - parse r bad $ \e -> return $ serialize False e + parse r bad $ \e -> pure $ serialize False e -- | Generalization of 'Data.SBV.Control.getAbduct'. getAbduct :: (SolverContext m, MonadIO m, MonadQuery m) => Maybe String -> String -> SBool -> m String getAbduct mbGrammar defName b = do s <- inNewContext (`sbvToSV` b) - let cmd = "(get-abduct " ++ defName ++ " " ++ show s ++ fromMaybe "" mbGrammar ++ ")" + let cmd = "(get-abduct " <> T.pack defName <> " " <> showText s <> T.pack (fromMaybe "" mbGrammar) <> ")" bad = unexpected "getAbduct" cmd "a get-abduct response" Nothing r <- ask cmd - parse r bad $ \e -> return $ serialize False e + parse r bad $ \e -> pure $ serialize False e -- | Generalization of 'Data.SBV.Control.getAbductNext'. getAbductNext :: (MonadIO m, MonadQuery m) => m String getAbductNext = do - let cmd = "(get-abduct-next)" + let cmd = "(get-abduct-next)" :: T.Text bad = unexpected "getAbductNext" cmd "a get-abduct-next response" Nothing r <- ask cmd - parse r bad $ \e -> return $ serialize False e + parse r bad $ \e -> pure $ serialize False e -- | Generalization of 'Data.SBV.Control.getInterpolantZ3'. Use this version with Z3. getInterpolantZ3 :: (MonadIO m, MonadQuery m) => [SBool] -> m String @@ -554,22 +555,22 @@ | length fs < 2 = error $ "SBV.getInterpolantZ3 requires at least two booleans, received: " ++ show fs | True - = do ss <- let fAll [] sofar = return $ reverse sofar + = do ss <- let fAll [] sofar = pure $ reverse sofar fAll (b:bs) sofar = do sv <- inNewContext (`sbvToSV` b) fAll bs (sv : sofar) in fAll fs [] - let cmd = "(get-interpolant " ++ unwords (map show ss) ++ ")" + let cmd = "(get-interpolant " <> T.pack (unwords (map show ss)) <> ")" bad = unexpected "getInterpolant" cmd "a get-interpolant response" Nothing r <- ask cmd - parse r bad $ \e -> return $ serialize False e + parse r bad $ \e -> pure $ serialize False e -- | Generalization of 'Data.SBV.Control.getAssertions' getAssertions :: (MonadIO m, MonadQuery m) => m [String] getAssertions = do - let cmd = "(get-assertions)" + let cmd = "(get-assertions)" :: T.Text bad = unexpected "getAssertions" cmd "a get-assertions response" $ Just [ "Make sure you use:" , "" @@ -583,13 +584,13 @@ r <- ask cmd parse r bad $ \pe -> case pe of - EApp xs -> return $ map render xs - _ -> return [render pe] + EApp xs -> pure $ map render xs + _ -> pure [render pe] -- | Generalization of 'Data.SBV.Control.getAssignment' getAssignment :: (MonadIO m, MonadQuery m) => m [(String, Bool)] getAssignment = do - let cmd = "(get-assignment)" + let cmd = "(get-assignment)" :: T.Text bad = unexpected "getAssignment" cmd "a get-assignment response" $ Just [ "Make sure you use:" , "" @@ -606,7 +607,7 @@ r <- ask cmd - parse r bad $ \case EApp ps | Just vs <- mapM grab ps -> return vs + parse r bad $ \case EApp ps | Just vs <- mapM grab ps -> pure vs _ -> bad r Nothing -- | Make an assignment. The type 'Assignment' is abstract, the result is typically passed @@ -636,7 +637,7 @@ QueryState{queryConfig} <- getQueryState inps <- F.toList <$> getTopLevelInputs - let grabValues st = do let extract (Assign s n) = sbvToSV st (SBV s) >>= \sv -> return (sv, n) + let grabValues st = do let extract (Assign s n) = sbvToSV st (SBV s) >>= \sv -> pure (sv, n) modelAssignment <- mapM extract asgns @@ -687,7 +688,7 @@ , "*** Candidates: " ++ unwords nms ] - return [(findName s, n) | (s, n) <- modelAssignment] + pure [(findName s, n) | (s, n) <- modelAssignment] assocs <- inNewContext grabValues @@ -697,4 +698,4 @@ , modelUIFuns = [] } - return $ Satisfiable queryConfig m + pure $ Satisfiable queryConfig m diff --git a/Data/SBV/Control/Utils.hs b/Data/SBV/Control/Utils.hs --- a/Data/SBV/Control/Utils.hs +++ b/Data/SBV/Control/Utils.hs @@ -16,28 +16,28 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Control.Utils ( io , ask, send, getValue, getFunction , getValueCV, getUICVal, getUIFunCVAssoc, getUnsatAssumptions , SMTFunction(..), getQueryState, modifyQueryState, getConfig, getObjectives, getUIs - , getSBVAssertions, getSBVPgm, getObservables + , getSBVAssertions, getObservables , checkSat, checkSatUsing, getAllSatResult , inNewContext, freshVar, freshVar_ , getTopLevelInputs, parse, unexpected - , timeout, queryDebug, retrieveResponse, recoverKindedValue, runProofOn, executeQuery + , timeout, queryDebug, retrieveResponse, runProofOn, executeQuery , startOptimizer, getObjectiveValues, getModel, getModelAtIndex ) where -import Data.List (sortBy, sortOn, partition, groupBy, tails, intercalate, isPrefixOf, isSuffixOf) +import Data.List (sortOn, partition, groupBy, tails, intercalate, isPrefixOf, isSuffixOf) import Data.Char (isPunctuation, isSpace, isDigit) import Data.Function (on) @@ -45,13 +45,13 @@ import Data.Proxy -import qualified Data.Foldable as F (toList) +import qualified Data.Foldable as F (toList, for_) import qualified Data.Map.Strict as Map import qualified Data.Set as Set (empty, fromList, toAscList) import qualified Data.Sequence as S import qualified Data.Text as T -import Control.Monad (join, unless, zipWithM, when, replicateM, forM_) +import Control.Monad (join, unless, zipWithM, when, replicateM) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans (lift) import Control.Monad.Reader (runReaderT) @@ -70,7 +70,7 @@ , newExpr, SBVExpr(..), Op(..), FPOp(..), SBV(..) , SolverContext(..), SBool, Objective(..), SolverCapabilities(..), capabilities , Result(..), SMTProblem(..), trueSV, SymVal(..), SBVPgm(..), SMTSolver(..), SBVRunMode(..) - , SBVType(..), forceSVArg, RoundingMode(RoundNearestTiesToEven), (.=>) + , SBVType(..), forceSVArg, (.=>) , RCSet(..), QuantifiedBool(..), ArrayModel(..), SInfo(..), getSInfo , OptimizeStyle(..), GeneralizedCV(..), ExtCV(..) ) @@ -80,9 +80,9 @@ , registerLabel, svMkSymVar, validationRequested , isSafetyCheckingIStage, isSetupIStage, isRunIStage, IStage(..), QueryT(..) , extractSymbolicSimulationState, MonadSymbolic(..) - , UserInputs, getSV, NamedSymVar(..), lookupInput, getUserName' + , UserInputs, getSV, NamedSymVar(..), lookupInput, getUserName, getUserName' , Name, CnstMap, Inputs(..), ProgInfo(..) - , mustIgnoreVar, newInternalVariable, Penalty(..) + , mustIgnoreVar, newInternalVariable, Penalty(..), smtLibPgmText ) import Data.SBV.Core.AlgReals (mergeAlgReals, AlgReal(..), RealPoint(..)) @@ -98,7 +98,7 @@ ) import Data.SBV.Utils.ExtractIO -import Data.SBV.Utils.Lib (qfsToString, unBar) +import Data.SBV.Utils.Lib (qfsToString, unBar, mapToSortedList, showText) import Data.SBV.Utils.SExpr import Data.SBV.Utils.PrettyNum (cvToSMTLib) @@ -128,7 +128,7 @@ , "*** Hint: Move the call to 'setOption' before the query." ] | True = do State{stCfg} <- contextState - send True $ T.unpack $ setSMTOption stCfg o + send True $ setSMTOption stCfg o -- | Adding a constraint, possibly with attributes and possibly soft. Only used internally. -- Use 'constrain' and 'namedConstraint' from user programs. @@ -137,7 +137,7 @@ sbvToSV st b) unless (null atts && sv == trueSV) $ - send True $ "(" ++ asrt ++ " " ++ T.unpack (addAnnotations atts (T.pack (show sv))) ++ ")" + send True $ "(" <> T.pack asrt <> " " <> addAnnotations atts (showText sv) <> ")" where asrt | isSoft = "assert-soft" | True = "assert" @@ -150,11 +150,6 @@ getObjectives = do State{rOptGoals} <- queryState io $ reverse <$> readIORef rOptGoals --- | Get the program -getSBVPgm :: (MonadIO m, MonadQuery m) => m SBVPgm -getSBVPgm = do State{spgm} <- queryState - io $ readIORef spgm - -- | Get the assertions put in via 'Data.SBV.sAssert' getSBVAssertions :: (MonadIO m, MonadQuery m) => m [(String, Maybe CallStack, SV)] getSBVAssertions = do State{rAsserts} <- queryState @@ -176,19 +171,17 @@ writeIORef rGlobalConsts allConsts pure (nc, allConsts) - ls <- io $ do let swap (a, b) = (b, a) - cmp (a, _) (b, _) = a `compare` b - arrange (i, (at, rt, es)) = ((i, at, rt), es) + ls <- io $ do let arrange (i, (at, rt, es)) = ((i, at, rt), es) inps <- reverse <$> readIORef (rNewInps is) ks <- readIORef (rNewKinds is) - tbls <- map arrange . sortBy cmp . map swap . Map.toList <$> readIORef (rNewTbls is) + tbls <- map arrange . mapToSortedList <$> readIORef (rNewTbls is) uis <- Map.toAscList <$> readIORef (rNewUIs is) as <- readIORef (rNewAsgns is) constraints <- readIORef (rNewConstraints is) - let cnsts = sortBy cmp . map swap . Map.toList $ newConsts + let cnsts = mapToSortedList newConsts - return $ map T.unpack $ toIncSMTLib cfg progInfo inps ks (allConsts, cnsts) tbls uis as constraints cfg + pure $ toIncSMTLib cfg progInfo inps ks (allConsts, cnsts) tbls uis as constraints cfg mapM_ (send True) $ mergeSExpr ls @@ -201,7 +194,7 @@ , "*** Data.SBV: Impossible happened: Query context required in a non-query mode." , "Please report this as a bug!" ] - Just qs -> return qs + Just qs -> pure qs -- | Generalization of 'Data.SBV.Control.modifyQueryState' modifyQueryState :: (MonadIO m, MonadQuery m) => (QueryState -> QueryState) -> m () @@ -221,7 +214,7 @@ (is, r) <- io $ withNewIncState st act progInfo <- io $ readIORef rProgInfo syncUpSolver progInfo rconstMap is - return r + pure r -- | Generalization of 'Data.SBV.Control.freshVar_' freshVar_ :: forall a m. (MonadIO m, MonadQuery m, SymVal a) => m (SBV a) @@ -234,31 +227,30 @@ where k = kindOf (Proxy @a) -- | Generalization of 'Data.SBV.Control.queryDebug' -queryDebug :: (MonadIO m, MonadQuery m) => [String] -> m () +queryDebug :: (MonadIO m, MonadQuery m) => [T.Text] -> m () queryDebug msgs = do QueryState{queryConfig} <- getQueryState io $ do debug queryConfig msgs - -- If we're doing a transcript, record it there too - recordTranscript (transcript queryConfig) (DebugMsg (unlines msgs)) + recordTranscript (transcript queryConfig) (DebugMsg (T.unlines msgs)) -- | We need to track sent asserts/check-sat calls so we can issue an extra check-sat call if needed -trackAsserts :: (MonadIO m, MonadQuery m) => String -> m () +trackAsserts :: (MonadIO m, MonadQuery m) => T.Text -> m () trackAsserts s | isCheckSat || isAssert = do State{rOutstandingAsserts} <- queryState liftIO $ writeIORef rOutstandingAsserts isAssert | True = pure () - where trimmedS = dropWhile isSpace s - isCheckSat = "(check-sat" `isPrefixOf` trimmedS - isAssert = "(assert" `isPrefixOf` trimmedS + where trimmedS = T.dropWhile isSpace s + isCheckSat = "(check-sat" `T.isPrefixOf` trimmedS + isAssert = "(assert" `T.isPrefixOf` trimmedS -- | Generalization of 'Data.SBV.Control.ask' -ask :: (MonadIO m, MonadQuery m) => String -> m String +ask :: (MonadIO m, MonadQuery m) => T.Text -> m String ask s = askIgnoring s [] -- | Send a string to the solver, and return the response. Except, if the response -- is one of the "ignore" ones, keep querying. -askIgnoring :: (MonadIO m, MonadQuery m) => String -> [String] -> m String +askIgnoring :: (MonadIO m, MonadQuery m) => T.Text -> [String] -> m String askIgnoring s ignoreList = do trackAsserts s @@ -267,23 +259,23 @@ case queryTimeOutValue of Nothing -> queryDebug ["[SEND] " `alignPlain` s] - Just i -> queryDebug ["[SEND, TimeOut: " ++ showTimeoutValue i ++ "] " `alignPlain` s] + Just i -> queryDebug ["[SEND, TimeOut: " <> showTimeoutValue i <> "] " `alignPlain` s] r <- io $ queryAsk queryTimeOutValue s - queryDebug ["[RECV] " `alignPlain` r] + queryDebug ["[RECV] " `alignPlain` T.pack r] let loop currentResponse | currentResponse `notElem` ignoreList - = return currentResponse + = pure currentResponse | True = do queryDebug ["[WARN] Previous response is explicitly ignored, beware!"] newResponse <- io $ queryRetrieveResponse queryTimeOutValue - queryDebug ["[RECV] " `alignPlain` newResponse] + queryDebug ["[RECV] " `alignPlain` T.pack newResponse] loop newResponse loop r -- | Generalization of 'Data.SBV.Control.send' -send :: (MonadIO m, MonadQuery m) => Bool -> String -> m () +send :: (MonadIO m, MonadQuery m) => Bool -> T.Text -> m () send requireSuccess s = do trackAsserts s @@ -297,11 +289,11 @@ ["success"] -> queryDebug ["[GOOD] " `alignPlain` s] _ -> do case queryTimeOutValue of Nothing -> queryDebug ["[FAIL] " `alignPlain` s] - Just i -> queryDebug [("[FAIL, TimeOut: " ++ showTimeoutValue i ++ "] ") `alignPlain` s] + Just i -> queryDebug ["[FAIL, TimeOut: " <> showTimeoutValue i <> "] " `alignPlain` s] - let cmd = case words (dropWhile (\c -> isSpace c || isPunctuation c) s) of - (c:_) -> c + let cmd = case T.words (T.dropWhile (\c -> isSpace c || isPunctuation c) s) of + (c:_) -> T.unpack c _ -> "Command" unexpected cmd s "success" Nothing r Nothing @@ -318,9 +310,9 @@ let synchTag = show $ userTag ++ " (at: " ++ ts ++ ")" cmd = "(echo " ++ synchTag ++ ")" - queryDebug ["[SYNC] Attempting to synchronize with tag: " ++ synchTag] + queryDebug ["[SYNC] Attempting to synchronize with tag: " <> T.pack synchTag] - send False cmd + send False (T.pack cmd) QueryState{queryRetrieveResponse} <- getQueryState @@ -331,9 +323,9 @@ -- echo'ed strings, but they don't always do. Accommodate for that -- here, though I wish we didn't have to. if s == synchTag || show s == synchTag - then do queryDebug ["[SYNC] Synchronization achieved using tag: " ++ synchTag] - return $ reverse sofar - else do queryDebug ["[RECV] " `alignPlain` s] + then do queryDebug ["[SYNC] Synchronization achieved using tag: " <> T.pack synchTag] + pure $ reverse sofar + else do queryDebug ["[RECV] " `alignPlain` T.pack s] loop (s : sofar) loop [] @@ -386,7 +378,7 @@ ] ++ map (" " ++) (lines (show mdl))) cv <- getValueCV Nothing sv - return $ fromCV cv + pure $ fromCV cv -- | A class which allows for sexpr-conversion to functions class (HasKind r, SatModel r) => SMTFunction fun a r | fun -> a r where @@ -443,14 +435,14 @@ case S.findIndexR ((== r) . fst) asgns of Nothing -> cantFind uiMap Just i -> case asgns `S.index` i of - (sv, SBVApp (Uninterpreted nm) _) | r == sv -> return nm + (sv, SBVApp (Uninterpreted nm) _) | r == sv -> pure (T.unpack nm) _ -> cantFind uiMap sexprToFun f (s, e) = do nm <- fst . fst <$> smtFunName f si <- contextState >>= getSInfo mbRes <- case parseSExprFunction e of Just (Left nm') -> case (nm == nm', smtFunDefault f) of - (True, Just v) -> return $ Just ([], v) + (True, Just v) -> pure $ Just ([], v) _ -> bailOut nm Just (Right v) -> convert si v Nothing -> do mbPVS <- pointWiseExtract nm (smtFunType f) @@ -494,13 +486,13 @@ as = unwords $ map shc args - cmd = "(get-value ((" ++ nm ++ " " ++ as ++ ")))" + cmd = "(get-value ((" <> T.pack nm <> " " <> T.pack as <> ")))" bad = unexpected "get-value" cmd ("pointwise value of boolean function " ++ nm ++ " on " ++ show as) Nothing r <- ask cmd - parse r bad $ \case EApp [EApp [_, e]] -> return (args, e) + parse r bad $ \case EApp [EApp [_, e]] -> pure (args, e) _ -> bad r Nothing getBVals :: m [([SExpr], SExpr)] @@ -508,14 +500,14 @@ tryPointWise | not isBoolFunc - = return Nothing + = pure Nothing | nArgs < 1 = error $ "Data.SBV.pointWiseExtract: Impossible happened, nArgs < 1: " ++ show nArgs ++ " type: " ++ show typ | True = do vs <- getBVals -- Pick the value that will give us the fewer entries let (trues, falses) = partition (\(_, v) -> isTrueSExpr v) vs - return $ Just $ if length trues <= length falses + pure $ Just $ if length trues <= length falses then (trues, falseSExpr) else (falses, trueSExpr) @@ -844,7 +836,7 @@ => fun -> m (Either (String, (Bool, Maybe [String], SExpr)) ([(a, r)], r)) getFunction f = do ((nm, args), isCurried) <- smtFunName f - let cmd = "(get-value (" ++ nm ++ "))" + let cmd = "(get-value (" <> T.pack nm <> "))" bad = unexpected "getFunction" cmd "a function value" Nothing r <- ask cmd @@ -854,16 +846,16 @@ parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> do mbAssocs <- sexprToFun f (trimFunctionResponse r nm isCurried args, e) case mbAssocs of - Right assocs -> return $ Right assocs + Right assocs -> pure $ Right assocs Left raw -> do let rawRes = Left (raw, (isCurried, args, e)) mbPVS <- pointWiseExtract nm (smtFunType f) case mbPVS of Just ps -> do rs <- convert si ps case rs of - Just x -> return $ Right x - Nothing -> return rawRes - Nothing -> return rawRes + Just x -> pure $ Right x + Nothing -> pure rawRes + Nothing -> pure rawRes _ -> bad r Nothing where convert si (vs, d) = do ps <- mapM (sexprPoint si) vs pure $ (,) <$> sequenceA ps <*> sexprToVal si d @@ -875,9 +867,9 @@ getValueCVHelper :: (MonadIO m, MonadQuery m) => Maybe Int -> SV -> m CV getValueCVHelper mbi s | s == trueSV - = return trueCV + = pure trueCV | s == falseSV - = return falseCV + = pure falseCV | True = extractValue mbi (show s) (kindOf s) @@ -1166,13 +1158,13 @@ else do send True "(set-option :pp.decimal false)" rep1 <- getValueCVHelper mbi s send True "(set-option :pp.decimal true)" - send True $ "(set-option :pp.decimal_precision " ++ show (printRealPrec cfg) ++ ")" + send True $ "(set-option :pp.decimal_precision " <> showText (printRealPrec cfg) <> ")" rep2 <- getValueCVHelper mbi s let bad = unexpected "getValueCV" "get-value" ("a real-valued binding for " ++ show s) Nothing (show (rep1, rep2)) Nothing case (rep1, rep2) of - (CV KReal (CAlgReal a), CV KReal (CAlgReal b)) -> return $ CV KReal (CAlgReal (mergeAlgReals ("Cannot merge real-values for " ++ show s) a b)) + (CV KReal (CAlgReal a), CV KReal (CAlgReal b)) -> pure $ CV KReal (CAlgReal (mergeAlgReals ("Cannot merge real-values for " ++ show s) a b)) _ -> bad -- | Retrieve value from the solver @@ -1182,7 +1174,7 @@ Nothing -> "" Just i -> " :model_index " ++ show i - cmd = "(get-value (" ++ nm ++ ")" ++ modelIndex ++ ")" + cmd = "(get-value (" <> T.pack nm <> ")" <> T.pack modelIndex <> ")" bad = unexpected "get-value" cmd ("a value binding for kind: " ++ show k) Nothing @@ -1191,7 +1183,7 @@ si <- queryState >>= getSInfo let recover val = case recoverKindedValue si k val of - Just cv -> return cv + Just cv -> pure cv Nothing -> bad r Nothing parse r bad $ \case EApp [EApp [ECon v, val]] | v == nm -> recover val @@ -1210,7 +1202,7 @@ Nothing -> "" Just i -> " :model_index " ++ show i - cmd = "(get-value (" ++ nm ++ ")" ++ modelIndex ++ ")" + cmd = "(get-value (" <> T.pack nm <> ")" <> T.pack modelIndex <> ")" bad = unexpected "get-value" cmd "a function value" Nothing @@ -1241,10 +1233,10 @@ Just sExprs -> pure $ maybe (Left fallBack) Right (convert sExprs) parse r bad $ \case EApp [EApp [ECon o, e]] | o == nm -> case parseSExprFunction e of - Just (Right assocs) | Just res <- convert assocs -> return (Right res) + Just (Right assocs) | Just res <- convert assocs -> pure (Right res) | True -> tryPointWise - Just (Left nm') | nm == nm', let res = defaultKindedValue rt -> return (Right ([], res)) + Just (Left nm') | nm == nm', let res = defaultKindedValue rt -> pure (Right ([], res)) | True -> bad r Nothing Nothing -> tryPointWise @@ -1258,22 +1250,22 @@ -- | Generalization of 'Data.SBV.Control.checkSatUsing' checkSatUsing :: (MonadIO m, MonadQuery m) => String -> m CheckSatResult -checkSatUsing cmd = do let bad = unexpected "checkSat" cmd "one of sat/unsat/unknown" Nothing +checkSatUsing cmd = do let bad = unexpected "checkSat" (T.pack cmd) "one of sat/unsat/unknown" Nothing -- Sigh.. Ignore some of the pesky warnings. We only do it as an exception here. ignoreList = ["WARNING: optimization with quantified constraints is not supported"] - r <- askIgnoring cmd ignoreList + r <- askIgnoring (T.pack cmd) ignoreList -- query for the precision if supported let getPrecision = do cfg <- getConfig case supportsDeltaSat (capabilities (solver cfg)) of Nothing -> pure Nothing - Just o -> Just <$> ask o + Just o -> Just <$> ask (T.pack o) - parse r bad $ \case ECon "sat" -> return Sat - ECon "unsat" -> return Unsat - ECon "unknown" -> return Unk + parse r bad $ \case ECon "sat" -> pure Sat + ECon "unsat" -> pure Unsat + ECon "unknown" -> pure Unk ECon "delta-sat" -> DSat <$> getPrecision _ -> bad r Nothing @@ -1291,7 +1283,7 @@ rObs <- liftIO $ readIORef rObservables -- This intentionally reverses the result; since 'rObs' stores in reversed order - let walk [] !sofar = return sofar + let walk [] !sofar = pure sofar walk ((n, f, s):os) !sofar = do cv <- getValueCV Nothing s if f cv then walk os ((n, cv) : sofar) @@ -1308,7 +1300,7 @@ prior <- io $ readIORef rUIMap new <- io $ readIORef rIncState >>= readIORef . rNewUIs - return $ Map.toList $ Map.withoutKeys (Map.union prior new) defineSet + pure $ Map.toList $ Map.withoutKeys (Map.union prior new) defineSet -- | Return all satisfying models. getAllSatResult :: forall m. (MonadIO m, MonadQuery m, SolverContext m) => m AllSatResult @@ -1335,21 +1327,21 @@ -- Functions have at least two kinds in their type and all components must be "interpreted" let allUiFuns = [u | allSatTrackUFs cfg -- config says consider UIFs , u@(nm, (_, _, SBVType as)) <- allUninterpreteds, length as > 1 -- get the function ones - , not (mustIgnoreVar cfg nm) -- make sure they aren't explicitly ignored + , not (mustIgnoreVar cfg (T.pack nm)) -- make sure they aren't explicitly ignored ] allUiRegs = [u | u@(nm, (_, _, SBVType as)) <- allUninterpreteds, length as == 1 -- non-function ones - , not (mustIgnoreVar cfg nm) -- make sure they aren't explicitly ignored + , not (mustIgnoreVar cfg (T.pack nm)) -- make sure they aren't explicitly ignored ] -- We can only "allSat" if all component types themselves are interpreted. (Otherwise -- there is no way to reflect back the values to the solver.) - collectAcceptable [] sofar = return sofar + collectAcceptable [] sofar = pure sofar collectAcceptable ((nm, (_, _, t@(SBVType ats))):rest) sofar | not (any hasUninterpretedSorts ats) = collectAcceptable rest (nm : sofar) | True - = do queryDebug [ "*** SBV.allSat: Uninterpreted function: " ++ nm ++ " :: " ++ show t + = do queryDebug [ "*** SBV.allSat: Uninterpreted function: " <> T.pack nm <> " :: " <> showText t , "*** Will *not* be used in allSat considerations since its type" , "*** has uninterpreted sorts present." ] @@ -1362,20 +1354,18 @@ -- as cex's tend to get larger unless (null uiFuns) $ let solverCaps = capabilities (solver cfg) - in case supportsFlattenedModels solverCaps of - Nothing -> return () - Just cmds -> mapM_ (send True) cmds + in F.for_ (supportsFlattenedModels solverCaps) (mapM_ (send True . T.pack)) let usorts = [s | us@(KADT s _ _) <- Set.toAscList ki, isUninterpreted us] - unless (null usorts) $ queryDebug [ "*** SBV.allSat: Uninterpreted sorts present: " ++ unwords usorts + unless (null usorts) $ queryDebug [ "*** SBV.allSat: Uninterpreted sorts present: " <> T.pack (unwords usorts) , "*** SBV will use equivalence classes to generate all-satisfying instances." ] -- Drop the things that are not model vars or internal - let mkSVal nm@(getSV -> sv) = (SVal (kindOf sv) (Right (cache (const (return sv)))), nm) + let mkSVal nm@(getSV -> sv) = (SVal (kindOf sv) (Right (cache (const (pure sv)))), nm) let extractVars :: S.Seq (SVal, NamedSymVar) - extractVars = mkSVal <$> S.filter (not . mustIgnoreVar cfg . getUserName') allModelInputs + extractVars = mkSVal <$> S.filter (not . mustIgnoreVar cfg . getUserName) allModelInputs vars :: S.Seq (SVal, NamedSymVar) vars = case partitionVars of @@ -1419,7 +1409,7 @@ if isSimple then do let mkVar :: (String, (Bool, Maybe [String], SBVType)) -> IO (SVal, NamedSymVar) - mkVar (nm, (_, _, SBVType [k])) = do sv <- newExpr topState k (SBVApp (Uninterpreted nm) []) + mkVar (nm, (_, _, SBVType [k])) = do sv <- newExpr topState k (SBVApp (Uninterpreted (T.pack nm)) []) let sval = SVal k $ Right $ cache $ \_ -> pure sv nsv = NamedSymVar sv (T.pack nm) pure (sval, nsv) @@ -1466,7 +1456,7 @@ else case allSatMaxModelCount cfg of Just maxModels | have >= maxModels -> do unless (allSatMaxModelCountReached sofar) $ do - queryDebug ["*** Maximum model count request of " ++ show maxModels ++ " reached, stopping the search."] + queryDebug ["*** Maximum model count request of " <> showText maxModels <> " reached, stopping the search."] when (allSatPrintAlong cfg) $ io $ putStrLn "Search stopped since model count request was reached." io $ modifyIORef' finalResult $ \(h, s, _, m) -> (h, s{ allSatMaxModelCountReached = True }, True, m) pure Nothing @@ -1475,31 +1465,29 @@ case mbCont of Nothing -> pure () Just cnt -> do - queryDebug ["Fast allSat, Looking for solution " ++ show cnt] + queryDebug ["Fast allSat, Looking for solution " <> showText cnt] cs <- checkSat case cs of Unsat -> pure () - Unk -> do let m = "Solver returned unknown, terminating query." - queryDebug ["*** " ++ m] - io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedUnknown = True}, True, Just ("[" ++ m ++ "]")) + Unk -> do queryDebug ["*** Solver returned unknown, terminating query."] + io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedUnknown = True}, True, Just "[Solver returned unknown, terminating query.]") - DSat _ -> do let m = "Solver returned delta-sat, terminating query." - queryDebug ["*** " ++ m] - io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedDSat = True}, True, Just ("[" ++ m ++ "]")) + DSat _ -> do queryDebug ["*** Solver returned delta-sat, terminating query."] + io $ modifyIORef' finalResult $ \(h, s, _, _) -> (h, s{allSatSolverReturnedDSat = True}, True, Just "[Solver returned delta-sat, terminating query.]") Sat -> do assocs <- mapM (\(sval, NamedSymVar sv n) -> do !cv <- getValueCV Nothing sv - return (sv, (n, (sval, cv)))) extractVars + pure (sv, (n, (sval, cv)))) extractVars bindings <- let grab i@(getSV -> sv) = case lookupInput fst sv assocs of - Just (_, (_, (_, cv))) -> return (i, cv) + Just (_, (_, (_, cv))) -> pure (i, cv) Nothing -> do !cv <- getValueCV Nothing sv - return (i, cv) + pure (i, cv) in if validationRequested cfg then Just <$> mapM grab allInputs - else return Nothing + else pure Nothing obsvs <- getObservables @@ -1554,7 +1542,7 @@ send True "(pop 1)" pure r - forM_ [0 .. length terms - 1] $ \i -> do + F.for_ [0 .. length terms - 1] $ \i -> do sc <- shouldContinue when sc $ do case S.splitAt i terms of (pre, rest@(cur S.:<| _)) -> scope cur pre $ walk False rest @@ -1566,11 +1554,11 @@ where go :: Int -> AllSatResult -> m AllSatResult go !cnt !sofar | Just maxModels <- allSatMaxModelCount cfg, cnt > maxModels - = do queryDebug ["*** Maximum model count request of " ++ show maxModels ++ " reached, stopping the search."] + = do queryDebug ["*** Maximum model count request of " <> showText maxModels <> " reached, stopping the search."] when (allSatPrintAlong cfg) $ io $ putStrLn "Search stopped since model count request was reached." - return $! sofar { allSatMaxModelCountReached = True } + pure $! sofar { allSatMaxModelCountReached = True } | True - = do queryDebug ["Looking for solution " ++ show cnt] + = do queryDebug ["Looking for solution " <> showText cnt] cs <- checkSat @@ -1578,23 +1566,21 @@ case cs of Unsat -> do endMsg Nothing - return sofar + pure sofar - Unk -> do let m = "Solver returned unknown, terminating query." - queryDebug ["*** " ++ m] - endMsg $ Just $ "[" ++ m ++ "]" - return sofar{ allSatSolverReturnedUnknown = True } + Unk -> do queryDebug ["*** Solver returned unknown, terminating query."] + endMsg $ Just "[Solver returned unknown, terminating query.]" + pure sofar{ allSatSolverReturnedUnknown = True } - DSat _ -> do let m = "Solver returned delta-sat, terminating query." - queryDebug ["*** " ++ m] - endMsg $ Just $ "[" ++ m ++ "]" - return sofar{ allSatSolverReturnedDSat = True } + DSat _ -> do queryDebug ["*** Solver returned delta-sat, terminating query."] + endMsg $ Just "[Solver returned delta-sat, terminating query.]" + pure sofar{ allSatSolverReturnedDSat = True } Sat -> do assocs <- mapM (\(sval, NamedSymVar sv n) -> do !cv <- getValueCV Nothing sv - return (sv, (n, (sval, cv)))) vars + pure (sv, (n, (sval, cv)))) vars let getUIFun ui@(nm, (isCurried, _, t)) = do cvs <- getUIFunCVAssoc Nothing ui - return (nm, (isCurried, t, cvs)) + pure (nm, (isCurried, t, cvs)) uiFunVals <- mapM getUIFun allUiFuns uiRegVals <- mapM (\ui@(nm, _) -> (nm,) <$> getUICVal Nothing ui) allUiRegs @@ -1602,12 +1588,12 @@ obsvs <- getObservables bindings <- let grab i@(getSV -> sv) = case lookupInput fst sv assocs of - Just (_, (_, (_, cv))) -> return (i, cv) + Just (_, (_, (_, cv))) -> pure (i, cv) Nothing -> do !cv <- getValueCV Nothing sv - return (i, cv) + pure (i, cv) in if validationRequested cfg then Just <$> mapM grab allInputs - else return Nothing + else pure Nothing let model = SMTModel { modelObjectives = [] , modelBindings = F.toList <$> bindings @@ -1618,14 +1604,14 @@ } m = Satisfiable cfg model - (interpreteds, uninterpreteds) = S.partition (not . isUninterpreted . kindOf . fst) (fmap (snd . snd) assocs) + (interpreteds, uninterpreteds) = S.partition (not . isUninterpreted . kindOf . fst) (snd . snd <$> assocs) interpretedRegUis = filter (not . isUninterpreted . kindOf . snd) uiRegVals interpretedRegUiSVs = [(cvt n (kindOf cv), cv) | (n, cv) <- interpretedRegUis] where cvt :: String -> Kind -> SVal cvt nm k = SVal k $ Right $ cache r - where r st = newExpr st k (SBVApp (Uninterpreted nm) []) + where r st = newExpr st k (SBVApp (Uninterpreted (T.pack nm)) []) -- For each interpreted variable, figure out the model equivalence -- NB. When the kind is floating, we *have* to be careful, since +/- zero, and NaN's @@ -1657,8 +1643,8 @@ -- For each uninterpreted function, create a disqualifying equation -- We do this rather brute-force, since we need to create a new function -- and do an existential assertion. - uninterpretedReject :: Maybe [String] - uninterpretedFuns :: [String] + uninterpretedReject :: Maybe [T.Text] + uninterpretedFuns :: [T.Text] (uninterpretedReject, uninterpretedFuns) = (uiReject, concat defs) where uiReject = case rejects of [] -> Nothing @@ -1690,39 +1676,39 @@ , "*** NB. If this is a use case you'd like SBV to support, please get in touch!" ] mkNotEq (nm, (_, SBVType ts, Right vs)) = (reject, def ++ dif) - where nm' = nm ++ "_model" ++ show cnt + where nm' = T.pack nm <> "_model" <> showText cnt - reject = nm' ++ "_reject" + reject = nm' <> "_reject" - -- rounding mode doesn't matter here, just pick one - scv = cvToSMTLib RoundNearestTiesToEven + -- convert a constant + scv = cvToSMTLib (ats, rt) = (init ts, last ts) - args = unwords ["(x!" ++ show i ++ " " ++ smtType t ++ ")" | (t, i) <- zip ats [(0::Int)..]] + args = T.unwords ["(x!" <> showText i <> " " <> smtType t <> ")" | (t, i) <- zip ats [(0::Int)..]] res = smtType rt - params = ["x!" ++ show i | (_, i) <- zip ats [(0::Int)..]] + params = ["x!" <> showText i | (_, i) <- zip ats [(0::Int)..]] - uparams = unwords params + uparams = T.unwords params chain (vals, fallThru) = walk vals - where walk [] = [" " ++ scv fallThru ++ replicate (length vals) ')'] - walk ((as, r) : rest) = (" (ite " ++ cond as ++ " " ++ scv r) : walk rest + where walk [] = [" " <> scv fallThru <> T.replicate (length vals) ")"] + walk ((as, r) : rest) = (" (ite " <> cond as <> " " <> scv r) : walk rest - cond as = "(and " ++ unwords (zipWith eq params as) ++ ")" - eq p a = "(= " ++ p ++ " " ++ scv a ++ ")" + cond as = "(and " <> T.unwords (zipWith eq params as) <> ")" + eq p a = "(= " <> p <> " " <> scv a <> ")" - def = ("(define-fun " ++ nm' ++ " (" ++ args ++ ") " ++ res) + def = ("(define-fun " <> nm' <> " (" <> args <> ") " <> res) : chain vs ++ [")"] - pad = replicate (1 + length nm' - length nm) ' ' + pad = T.replicate (1 + T.length nm' - length nm) " " - dif = [ "(define-fun " ++ reject ++ " () Bool" - , " (exists (" ++ args ++ ")" - , " (distinct (" ++ nm ++ pad ++ uparams ++ ")" - , " (" ++ nm' ++ " " ++ uparams ++ "))))" + dif = [ "(define-fun " <> reject <> " () Bool" + , " (exists (" <> args <> ")" + , " (distinct (" <> T.pack nm <> pad <> uparams <> ")" + , " (" <> nm' <> " " <> uparams <> "))))" ] eqs = interpretedEqs ++ uninterpretedEqs @@ -1748,36 +1734,37 @@ else do let uiFunRejector = "uiFunRejector_model_" ++ show cnt header = "define-fun " ++ uiFunRejector ++ " () Bool " - defineRejector [] = return () - defineRejector [x] = send True $ "(" ++ header ++ x ++ ")" - defineRejector (x:xs) = mapM_ (send True) $ mergeSExpr $ ("(" ++ header) - : (" (or " ++ x) - : [" " ++ e | e <- xs] - ++ [" ))"] + defineRejector [] = pure () + defineRejector [x] = send True $ "(" <> T.pack header <> x <> ")" + defineRejector (x:xs) = mapM_ (send True) $ mergeSExpr + $ T.pack ("(" ++ header) + : (" (or " <> x) + : [" " <> e | e <- xs] + ++ [" ))"] rejectFuncs <- case uninterpretedReject of - Nothing -> return Nothing + Nothing -> pure Nothing Just fs -> do mapM_ (send True) $ mergeSExpr uninterpretedFuns defineRejector fs - return $ Just uiFunRejector + pure $ Just uiFunRejector -- send the disallow clause and the uninterpreted rejector: case (disallow, rejectFuncs) of (Nothing, Nothing) -> pure resultsSoFar (Just d, Nothing) -> do constrain d go (cnt+1) resultsSoFar - (Nothing, Just f) -> do send True $ "(assert " ++ f ++ ")" + (Nothing, Just f) -> do send True $ "(assert " <> T.pack f <> ")" go (cnt+1) resultsSoFar (Just d, Just f) -> -- This is where it gets ugly. We have an SBV and a string and we need to "or" them. -- But we need a way to force 'd' to be produced. So, go ahead and force it: do constrain $ d .=> d -- NB: Redundant, but it makes sure the corresponding constraint gets shown svd <- io $ svToSV topState (unSBV d) - send True $ "(assert (or " ++ f ++ " " ++ show svd ++ "))" + send True $ "(assert (or " <> T.pack f <> " " <> showText svd <> "))" go (cnt+1) resultsSoFar -- | Generalization of 'Data.SBV.Control.getUnsatAssumptions' getUnsatAssumptions :: (MonadIO m, MonadQuery m) => [String] -> [(String, a)] -> m [a] getUnsatAssumptions originals proxyMap = do - let cmd = "(get-unsat-assumptions)" + let cmd = "(get-unsat-assumptions)" :: T.Text bad = unexpected "getUnsatAssumptions" cmd "a list of unsatisfiable assumptions" $ Just [ "Make sure you use:" @@ -1797,13 +1784,13 @@ -- in the original list of assumptions for `check-sat-assuming`. So, we walk over -- and ignore those that weren't in the original list, and put a warning for those -- we couldn't find. - let walk [] sofar = return $ reverse sofar + let walk [] sofar = pure $ reverse sofar walk (a:as) sofar = case a `lookup` proxyMap of Just v -> walk as (v:sofar) Nothing -> do queryDebug [ "*** In call to 'getUnsatAssumptions'" , "***" - , "*** Unexpected assumption named: " ++ show a - , "*** Was expecting one of : " ++ show originals + , "*** Unexpected assumption named: " <> showText a + , "*** Was expecting one of : " <> showText originals , "***" , "*** This can happen if unsat-cores are also enabled. Ignoring." ] @@ -1831,7 +1818,7 @@ timeout n q = do modifyQueryState (\qs -> qs {queryTimeOutValue = Just n}) r <- q modifyQueryState (\qs -> qs {queryTimeOutValue = Nothing}) - return r + pure r -- | Bail out if a parse goes bad parse :: String -> (String -> Maybe [String] -> a) -> (SExpr -> a) -> a @@ -1840,7 +1827,7 @@ Right res -> sCont res -- | Generalization of 'Data.SBV.Control.unexpected' -unexpected :: (MonadIO m, MonadQuery m) => String -> String -> String -> Maybe [String] -> String -> Maybe [String] -> m a +unexpected :: (MonadIO m, MonadQuery m) => String -> T.Text -> String -> Maybe [String] -> String -> Maybe [String] -> m a unexpected ctx sent expected mbHint received mbReason = do -- empty the response channel first extras <- retrieveResponse "terminating upon unexpected response" (Just 5000000) @@ -1848,7 +1835,7 @@ cfg <- getConfig let exc = SBVException { sbvExceptionDescription = "Unexpected response from the solver, context: " ++ ctx - , sbvExceptionSent = Just sent + , sbvExceptionSent = Just (T.unpack sent) , sbvExceptionExpected = Just expected , sbvExceptionReceived = Just received , sbvExceptionStdOut = Just $ unlines extras @@ -1891,8 +1878,8 @@ -- Make sure the phases match: () <- liftIO $ case (queryContext, rm) of - (QueryInternal, _) -> return () -- no worries, internal - (QueryExternal, SMTMode QueryExternal ISetup _ _) -> return () -- legitimate runSMT call + (QueryInternal, _) -> pure () -- no worries, internal + (QueryExternal, SMTMode QueryExternal ISetup _ _) -> pure () -- legitimate runSMT call _ -> invalidQuery rm case rm of @@ -1922,12 +1909,12 @@ checks <- readIORef (rMeasureChecks st) unless (null checks) $ do let nms = map (\(n, _, _) -> n) checks - debug cfg ["[MEASURE] Verifying termination measures for: " ++ intercalate ", " nms] + debug cfg ["[MEASURE] Verifying termination measures for: " <> T.pack (intercalate ", " nms)] mapM_ (\(nm, isProductive, check) -> do - debug cfg ["[MEASURE] Checking: " ++ nm] + debug cfg ["[MEASURE] Checking: " <> T.pack nm] check cfg let tag = if isProductive then "productive" else "terminating" - debug cfg ["[MEASURE] Passed (" ++ tag ++ "): " ++ nm] + debug cfg ["[MEASURE] Passed (" <> tag <> "): " <> T.pack nm] ) checks let SMTProblem{smtLibPgm} = runProofOn rm queryContext [] res @@ -1939,7 +1926,7 @@ let terminateSolver maybeForwardedException = do qs <- readIORef $ rQueryState st case qs of - Nothing -> return () + Nothing -> pure () Just QueryState{queryTerminate} -> queryTerminate maybeForwardedException -- If this is an extrnal query and there are objectives, let's add those to the list before we run @@ -1949,14 +1936,14 @@ QueryExternal -> do mbDirs <- startOptimizer cfg Lexicographic case mbDirs of Nothing -> pure () - Just (_, cmds) -> mapM_ (send True) cmds + Just (_, cmds) -> mapM_ (send True . T.pack) cmds originalQuery lift $ join $ liftIO $ C.mask $ \restore -> do - r <- restore (extractIO $ join $ liftIO $ backend cfg' st (show pgm) $ extractIO . runReaderT (runQueryT userQuery)) + r <- restore (extractIO $ join $ liftIO $ backend cfg' st (smtLibPgmText pgm) $ extractIO . runReaderT (runQueryT userQuery)) `C.catch` \e -> terminateSolver (Just e) >> C.throwIO (e :: C.SomeException) terminateSolver Nothing - return r + pure r -- Already in a query, in theory we can just continue, but that causes use-case issues -- so we reject it. TODO: Review if we should actually support this. The issue arises with @@ -2023,7 +2010,7 @@ objectives <- getObjectives if null objectives - then return Nothing + then pure Nothing else do unless (supportsOptimization (capabilities (solver config))) $ error $ unlines [ "" , "*** Data.SBV: The backend solver " ++ show (name (solver config)) ++ "does not support optimization goals." @@ -2066,7 +2053,7 @@ -- | Just after a check-sat is issued, collect objective values. Used -- internally only, not exposed to the user. getObjectiveValues :: forall m. (MonadIO m, MonadQuery m) => m [(String, GeneralizedCV)] -getObjectiveValues = do let cmd = "(get-objectives)" +getObjectiveValues = do let cmd = "(get-objectives)" :: T.Text bad = unexpected "getObjectiveValues" cmd "a list of objective values" Nothing @@ -2083,13 +2070,13 @@ getObjValue :: SInfo -> (forall a. Maybe [String] -> m a) -> [NamedSymVar] -> SExpr -> m (Maybe (String, GeneralizedCV)) getObjValue si bailOut inputs expr = case expr of - EApp [_] -> return Nothing -- Happens when a soft-assertion has no associated group. + EApp [_] -> pure Nothing -- Happens when a soft-assertion has no associated group. EApp [ECon nm, v] -> locate nm v -- Regular case _ -> dontUnderstand (show expr) where locate nm v = case listToMaybe [p | p@(NamedSymVar sv _) <- inputs, show sv == nm] of - Nothing -> return Nothing -- Happens when the soft assertion has a group-id that's not one of the input names - Just (NamedSymVar sv actualName) -> grab sv v >>= \val -> return $ Just (T.unpack actualName, val) + Nothing -> pure Nothing -- Happens when the soft assertion has a group-id that's not one of the input names + Just (NamedSymVar sv actualName) -> grab sv v >>= \val -> pure $ Just (T.unpack actualName, val) dontUnderstand s = bailOut $ Just [ "Unable to understand solver output." , "While trying to process: " ++ s @@ -2097,19 +2084,19 @@ grab :: SV -> SExpr -> m GeneralizedCV grab s topExpr - | Just v <- recoverKindedValue si k topExpr = return $ RegularCV v + | Just v <- recoverKindedValue si k topExpr = pure $ RegularCV v | True = ExtendedCV <$> cvt (simplify topExpr) where k = kindOf s -- Convert to an extended expression. Hopefully complete! cvt :: SExpr -> m ExtCV - cvt (ECon "oo") = return $ Infinite k - cvt (ECon "epsilon") = return $ Epsilon k + cvt (ECon "oo") = pure $ Infinite k + cvt (ECon "epsilon") = pure $ Epsilon k cvt (EApp [ECon "interval", x, y]) = Interval <$> cvt x <*> cvt y - cvt (ENum (i, _, _)) = return $ BoundedCV $ mkConstCV k i - cvt (EReal r) = return $ BoundedCV $ CV k $ CAlgReal r - cvt (EFloat f) = return $ BoundedCV $ CV k $ CFloat f - cvt (EDouble d) = return $ BoundedCV $ CV k $ CDouble d + cvt (ENum (i, _, _)) = pure $ BoundedCV $ mkConstCV k i + cvt (EReal r) = pure $ BoundedCV $ CV k $ CAlgReal r + cvt (EFloat f) = pure $ BoundedCV $ CV k $ CFloat f + cvt (EDouble d) = pure $ BoundedCV $ CV k $ CDouble d cvt (EApp [ECon "+", x, y]) = AddExtCV <$> cvt x <*> cvt y cvt (EApp [ECon "*", x, y]) = MulExtCV <$> cvt x <*> cvt y -- Nothing else should show up, hopefully! @@ -2146,39 +2133,37 @@ let name = fst . snd removeSV = snd - prepare = S.unstableSort . S.filter (not . mustIgnoreVar cfg . T.unpack . name) - assocs = fmap removeSV (prepare inputAssocs) <> S.fromList (sortOn fst obsvs) + prepare = S.unstableSort . S.filter (not . mustIgnoreVar cfg . name) + assocs = (removeSV <$> prepare inputAssocs) <> S.fromList (sortOn fst obsvs) -- collect UIs, and UI functions if requested - let uiFuns = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as > 1, allSatTrackUFs cfg, not (mustIgnoreVar cfg nm)] -- functions have at least two things in their type! - uiRegs = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as == 1, not (mustIgnoreVar cfg nm)] + let uiFuns = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as > 1, allSatTrackUFs cfg, not (mustIgnoreVar cfg (T.pack nm))] -- functions have at least two things in their type! + uiRegs = [ui | ui@(nm, (_, _, SBVType as)) <- uis, length as == 1, not (mustIgnoreVar cfg (T.pack nm))] -- If there are uninterpreted functions, arrange so that z3's pretty-printer flattens things out -- as cex's tend to get larger unless (null uiFuns) $ let solverCaps = capabilities (solver cfg) - in case supportsFlattenedModels solverCaps of - Nothing -> return () - Just cmds -> mapM_ (send True) cmds + in F.for_ (supportsFlattenedModels solverCaps) (mapM_ (send True . T.pack)) bindings <- let get i@(getSV -> sv) = case lookupInput fst sv inputAssocs of - Just (_, (_, cv)) -> return (i, cv) + Just (_, (_, cv)) -> pure (i, cv) Nothing -> do cv <- getValueCV mbi sv - return (i, cv) + pure (i, cv) in if validationRequested cfg then Just <$> mapM get allModelInputs - else return Nothing + else pure Nothing uiFunVals <- mapM (\ui@(nm, (c, _, t)) -> (\a -> (nm, (c, t, a))) <$> getUIFunCVAssoc mbi ui) uiFuns uiVals <- mapM (\ui@(nm, (_, _, _)) -> (nm,) <$> getUICVal mbi ui) uiRegs - return $ unBarModel $ SMTModel { modelObjectives = [] - , modelBindings = F.toList <$> bindings - , modelAssocs = uiVals ++ F.toList (first T.unpack <$> assocs) - , modelUIFuns = uiFunVals - } + pure $ unBarModel $ SMTModel { modelObjectives = [] + , modelBindings = F.toList <$> bindings + , modelAssocs = uiVals ++ F.toList (first T.unpack <$> assocs) + , modelUIFuns = uiFunVals + } -- | Remove the bars from model names; these are (mostly!) automatically inserted unBarModel :: SMTModel -> SMTModel @@ -2189,7 +2174,11 @@ , modelUIFuns = ubf <$> modelUIFuns } where ubf (n, a) = (unBar n, a) - ubn (NamedSymVar sv nm, a) = (NamedSymVar sv (T.pack (unBar (T.unpack nm))), a) + ubn (NamedSymVar sv nm, a) = (NamedSymVar sv (unBarT nm), a) + + unBarT t = case T.uncons t of + Just ('|', rest) | not (T.null rest) && T.last rest == '|' -> T.init rest + _ -> t {- HLint ignore module "Reduce duplication" -} {- HLint ignore getAllSatResult "Use forM_" -} diff --git a/Data/SBV/Core/AlgReals.hs b/Data/SBV/Core/AlgReals.hs --- a/Data/SBV/Core/AlgReals.hs +++ b/Data/SBV/Core/AlgReals.hs @@ -15,7 +15,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.AlgReals ( AlgReal(..) @@ -349,4 +349,4 @@ -- Quickcheck instance instance Arbitrary AlgReal where - arbitrary = AlgRational True `fmap` arbitrary + arbitrary = AlgRational True <$> arbitrary diff --git a/Data/SBV/Core/Concrete.hs b/Data/SBV/Core/Concrete.hs --- a/Data/SBV/Core/Concrete.hs +++ b/Data/SBV/Core/Concrete.hs @@ -484,7 +484,7 @@ KSet ek -> do i <- randomIO -- regular or complement l <- randomRIO (0, 100) -- some set upto 100 elements vals <- Set.fromList <$> replicateM l (randomCVal ek) - return $ CSet $ if i then RegularSet vals else ComplementSet vals + pure $ CSet $ if i then RegularSet vals else ComplementSet vals KTuple ks -> CTuple <$> traverse randomCVal ks @@ -492,7 +492,7 @@ ks <- replicateM l (randomCVal k1) vs <- replicateM l (randomCVal k2) def <- randomCVal k2 - return $ CArray $ ArrayModel (zip ks vs) def + pure $ CArray $ ArrayModel (zip ks vs) def where bounds :: Bool -> Int -> (Integer, Integer) bounds False w = (0, 2^w - 1) diff --git a/Data/SBV/Core/Data.hs b/Data/SBV/Core/Data.hs --- a/Data/SBV/Core/Data.hs +++ b/Data/SBV/Core/Data.hs @@ -47,11 +47,11 @@ , SBV(..), NodeId(..), mkSymSBV , sbvToSV, sbvToSymSV, forceSVArg , RList(..), RNil, (:>), rlist2list - , SBVs(..), foldlSBVs, mapMSBVs, foldlSymSBVs + , SBVs(..), mapMSBVs, foldlSymSBVs , SBVExpr(..), newExpr , cache, Cached, uncache, HasKind(..) , Op(..), PBOp(..), FPOp(..), StrOp(..), RegExOp(..), SeqOp(..), RegExp(..), NamedSymVar(..), OvOp(..), getTableIndex - , SBVPgm(..), Symbolic, runSymbolic, State, SInfo(..), getSInfo, getPathCondition, extendPathCondition + , SBVPgm(..), Symbolic, runSymbolic, State, SInfo(..), getSInfo, getPathCondition , inSMTMode, SBVRunMode(..), Kind(..), Outputtable(..), Result(..) , SolverContext(..), internalConstraint, isCodeGenMode , SBVType(..), newUninterpreted @@ -108,10 +108,6 @@ getPathCondition :: State -> SBool getPathCondition st = SBV (getSValPathCondition st) --- | Extend the path condition with the given test value. -extendPathCondition :: State -> (SBool -> SBool) -> State -extendPathCondition st f = extendSValPathCondition st (unSBV . f . SBV) - -- | The "Symbolic" value. The parameter @a@ is phantom, but is -- extremely important in keeping the user interface strongly typed. newtype SBV a = SBV { unSBV :: SVal } @@ -422,7 +418,7 @@ -- | Map a monadic function over the SBV values in an SBVs sequence in a -- manner similar to 'mapM' for lists mapMSBVs :: Monad m => (forall a. SBV a -> m r) -> SBVs as -> m (RList r) -mapMSBVs f = foldlSBVs (\m arg -> (:>) <$> m <*> f arg) (return RNil) +mapMSBVs f = foldlSBVs (\m arg -> (:>) <$> m <*> f arg) (pure RNil) -- | Fold a function over each SBV value in an SBVs sequence in a manner similar -- to 'foldr' for lists (but backwards because SBVs have cons on the right), @@ -482,7 +478,7 @@ mkQArg :: forall m a. (HasKind a, MonadIO m) => State -> Quantifier -> m (SBV a) mkQArg st q = do let k = kindOf (Proxy @a) sv <- liftIO $ quantVar q st k - pure $ SBV $ SVal k (Right (cache (const (return sv)))) + pure $ SBV $ SVal k (Right (cache (const (pure sv)))) -- | Functions of a single existential instance (SymVal a, Constraint m r) => Constraint m (Exists nm a -> r) where @@ -523,7 +519,7 @@ mkLambda st fn = mkArg >>= mkLambda st . fn where mkArg = do let k = kindOf (Proxy @a) sv <- liftIO $ lambdaVar st k - pure $ SBV $ SVal k (Right (cache (const (return sv)))) + pure $ SBV $ SVal k (Right (cache (const (pure sv)))) -- | A value that can be used as a quantified boolean class QuantifiedBool a where @@ -611,13 +607,13 @@ instance Outputtable (SBV a) where output i = do outputSVal (unSBV i) - return i + pure i instance Outputtable a => Outputtable [a] where output = mapM output instance Outputtable () where - output = return + output = pure instance (Outputtable a, Outputtable b) => Outputtable (a, b) where output = mlift2 (,) output output diff --git a/Data/SBV/Core/Floating.hs b/Data/SBV/Core/Floating.hs --- a/Data/SBV/Core/Floating.hs +++ b/Data/SBV/Core/Floating.hs @@ -18,7 +18,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Floating ( IEEEFloating(..), IEEEFloatConvertible(..) @@ -382,9 +382,9 @@ -- | Add the converted rounding mode if given as an argument addRM :: State -> Maybe SRoundingMode -> [SV] -> IO [SV] -addRM _ Nothing as = return as +addRM _ Nothing as = pure as addRM st (Just rm) as = do svm <- sbvToSV st rm - return (svm : as) + pure (svm : as) -- | Lift a 1 arg FP-op lift1 :: SymVal a => FPOp -> Maybe (a -> a) -> Maybe SRoundingMode -> SBV a -> SBV a @@ -527,12 +527,17 @@ -- and it works as long as you do not have a @NaN@. sFloatAsComparableSWord32 :: SFloat -> SWord32 sFloatAsComparableSWord32 f = ite (fpIsNegativeZero f) (sFloatAsComparableSWord32 0) (fromBitsBE $ sNot sb : ite sb (map sNot rest) rest) - where (sb : rest) = blastBE $ sFloatAsSWord32 f + where (sb, rest) = case blastBE $ sFloatAsSWord32 f of + b : bs -> (b, bs) + [] -> error "sFloatAsComparableSWord32: impossible, blastBE produced empty list" -- | Inverse transformation to 'sFloatAsComparableSWord32'. sComparableSWord32AsSFloat :: SWord32 -> SFloat sComparableSWord32AsSFloat w = sWord32AsSFloat $ ite sb (fromBitsBE $ sFalse : rest) (fromBitsBE $ map sNot allBits) - where allBits@(sb : rest) = blastBE w + where allBits = blastBE w + (sb, rest) = case allBits of + b : bs -> (b, bs) + [] -> error "sComparableSWord32AsSFloat: impossible, blastBE produced empty list" -- | Convert a double to a comparable 'SWord64'. The trick is to ignore the -- sign of -0, and if it's a negative value flip all the bits, and otherwise @@ -540,13 +545,18 @@ -- and it works as long as you do not have a @NaN@. sDoubleAsComparableSWord64 :: SDouble -> SWord64 sDoubleAsComparableSWord64 d = ite (fpIsNegativeZero d) (sDoubleAsComparableSWord64 0) (fromBitsBE $ sNot sb : ite sb (map sNot rest) rest) - where (sb : rest) = blastBE $ sDoubleAsSWord64 d + where (sb, rest) = case blastBE $ sDoubleAsSWord64 d of + b : bs -> (b, bs) + [] -> error "sDoubleAsComparableSWord64: impossible, blastBE produced empty list" -- | Inverse transformation to 'sDoubleAsComparableSWord64'. Note that this isn't a perfect inverse, since @-0@ maps to @0@ and back to @0@. -- Otherwise, it's faithful: sComparableSWord64AsSDouble :: SWord64 -> SDouble sComparableSWord64AsSDouble w = sWord64AsSDouble $ ite sb (fromBitsBE $ sFalse : rest) (fromBitsBE $ map sNot allBits) - where allBits@(sb : rest) = blastBE w + where allBits = blastBE w + (sb, rest) = case allBits of + b : bs -> (b, bs) + [] -> error "sComparableSWord64AsSDouble: impossible, blastBE produced empty list" -- | 'Float' instance for 'Metric' goes through the lexicographic ordering on 'Word32'. -- It implicitly makes sure that the value is not @NaN@. @@ -559,12 +569,12 @@ msMinimize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @Float) nm when (nm' /= nm) $ sObserve nm (unSBV o) - addSValOptGoal $ unSBV `fmap` Minimize nm' (toMetricSpace o) + addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) msMaximize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @Float) nm when (nm' /= nm) $ sObserve nm (unSBV o) - addSValOptGoal $ unSBV `fmap` Maximize nm' (toMetricSpace o) + addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) annotateForMS _ s = "toMetricSpace(" ++ s ++ ")" @@ -579,12 +589,12 @@ msMinimize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @Double) nm when (nm' /= nm) $ sObserve nm (unSBV o) - addSValOptGoal $ unSBV `fmap` Minimize nm' (toMetricSpace o) + addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) msMaximize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @Double) nm when (nm' /= nm) $ sObserve nm (unSBV o) - addSValOptGoal $ unSBV `fmap` Maximize nm' (toMetricSpace o) + addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) annotateForMS _ s = "toMetricSpace(" ++ s ++ ")" @@ -613,13 +623,18 @@ sFloatingPointAsComparableSWord :: forall eb sb. (ValidFloat eb sb, KnownNat (eb + sb), BVIsNonZero (eb + sb)) => SFloatingPoint eb sb -> SWord (eb + sb) sFloatingPointAsComparableSWord f = ite (fpIsNegativeZero f) posZero (fromBitsBE $ sNot sb : ite sb (map sNot rest) rest) where posZero = sFloatingPointAsComparableSWord (0 :: SFloatingPoint eb sb) - (sb : rest) = blastBE (sFloatingPointAsSWord f :: SWord (eb + sb)) + (sb, rest) = case blastBE (sFloatingPointAsSWord f :: SWord (eb + sb)) of + b : bs -> (b, bs) + [] -> error "sFloatingPointAsComparableSWord: impossible, blastBE produced empty list" -- | Inverse transformation to 'sFloatingPointAsComparableSWord'. Note that this isn't a perfect inverse, since @-0@ maps to @0@ and back to @0@. -- Otherwise, it's faithful: sComparableSWordAsSFloatingPoint :: forall eb sb. (KnownNat (eb + sb), BVIsNonZero (eb + sb), ValidFloat eb sb) => SWord (eb + sb) -> SFloatingPoint eb sb sComparableSWordAsSFloatingPoint w = sWordAsSFloatingPoint $ ite signBit (fromBitsBE $ sFalse : rest) (fromBitsBE $ map sNot allBits) - where allBits@(signBit : rest) = blastBE w + where allBits = blastBE w + (signBit, rest) = case allBits of + b : bs -> (b, bs) + [] -> error "sComparableSWordAsSFloatingPoint: impossible, blastBE produced empty list" -- | Convert a word to an arbitrary float, by reinterpreting the bits of the word as the corresponding bits of the float. sWordAsSFloatingPoint :: forall eb sb. (KnownNat (eb + sb), BVIsNonZero (eb + sb), ValidFloat eb sb) => SWord (eb + sb) -> SFloatingPoint eb sb @@ -653,12 +668,12 @@ msMinimize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @(FloatingPoint eb sb)) nm when (nm' /= nm) $ sObserve nm (unSBV o) - addSValOptGoal $ unSBV `fmap` Minimize nm' (toMetricSpace o) + addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) msMaximize nm o = do constrain $ sNot $ fpIsNaN o let nm' = annotateForMS (Proxy @(FloatingPoint eb sb)) nm when (nm' /= nm) $ sObserve nm (unSBV o) - addSValOptGoal $ unSBV `fmap` Maximize nm' (toMetricSpace o) + addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) annotateForMS _ s = "toMetricSpace(" ++ s ++ ")" diff --git a/Data/SBV/Core/Kind.hs b/Data/SBV/Core/Kind.hs --- a/Data/SBV/Core/Kind.hs +++ b/Data/SBV/Core/Kind.hs @@ -16,6 +16,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} @@ -23,7 +24,7 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Kind ( Kind(..), HasKind(..), smtType, hasUninterpretedSorts @@ -57,7 +58,7 @@ import GHC.TypeLits -import Data.SBV.Utils.Lib (isKString) +import Data.SBV.Utils.Lib (isKString, showText) import Data.SBV.Utils.Numeric (RoundingMode) import GHC.Generics @@ -147,23 +148,23 @@ showBaseKind :: Kind -> Text showBaseKind = sh where sh (KVar s) = T.pack s - sh k@KBool = noS (T.pack $ show k) - sh (KBounded False n) = T.pack (pickType n "Word" "WordN ") <> T.pack (show n) - sh (KBounded True n) = T.pack (pickType n "Int" "IntN ") <> T.pack (show n) - sh (KApp s ks) = T.pack $ unwords (s : map (T.unpack . kindParen . sh) ks) - sh k@KUnbounded = noS (T.pack $ show k) - sh k@KReal = noS (T.pack $ show k) - sh k@KADT{} = T.pack $ show k -- Leave user-sorts untouched! - sh k@KFloat = noS (T.pack $ show k) - sh k@KDouble = noS (T.pack $ show k) - sh k@KFP{} = noS (T.pack $ show k) - sh k@KChar = noS (T.pack $ show k) - sh k@KString = noS (T.pack $ show k) - sh KRational = T.pack "Rational" - sh (KList k) = T.pack "[" <> sh k <> T.pack "]" - sh (KSet k) = T.pack "{" <> sh k <> T.pack "}" - sh (KTuple ks) = T.pack "(" <> T.pack (intercalate ", " (map (T.unpack . sh) ks)) <> T.pack ")" - sh (KArray k1 k2) = T.pack "Array " <> kindParen (sh k1) <> T.pack " " <> kindParen (sh k2) + sh k@KBool = noS (showText k) + sh (KBounded False n) = T.pack (pickType n "Word" "WordN ") <> showText n + sh (KBounded True n) = T.pack (pickType n "Int" "IntN ") <> showText n + sh (KApp s ks) = T.unwords (T.pack s : map (kindParen . sh) ks) + sh k@KUnbounded = noS (showText k) + sh k@KReal = noS (showText k) + sh k@KADT{} = showText k -- Leave user-sorts untouched! + sh k@KFloat = noS (showText k) + sh k@KDouble = noS (showText k) + sh k@KFP{} = noS (showText k) + sh k@KChar = noS (showText k) + sh k@KString = noS (showText k) + sh KRational = "Rational" + sh (KList k) = "[" <> sh k <> "]" + sh (KSet k) = "{" <> sh k <> "}" + sh (KTuple ks) = "(" <> T.intercalate ", " (map sh ks) <> ")" + sh (KArray k1 k2) = "Array " <> kindParen (sh k1) <> " " <> kindParen (sh k2) -- Drop the initial S if it's there noS s = case T.uncons s of @@ -185,33 +186,26 @@ then T.singleton '(' <> s <> T.singleton ')' else s --- | String version of kindParen for backward compatibility -kindParenStr :: String -> String -kindParenStr s@('[':_) = s -kindParenStr s@('(':_) = s -kindParenStr s | any isSpace s = '(' : s ++ ")" - | True = s - -- | How the type maps to SMT land -smtType :: Kind -> String -smtType (KVar s) = s +smtType :: Kind -> Text +smtType (KVar s) = T.pack s smtType KBool = "Bool" -smtType (KBounded _ sz) = "(_ BitVec " ++ show sz ++ ")" +smtType (KBounded _ sz) = "(_ BitVec " <> showText sz <> ")" smtType KUnbounded = "Int" smtType KReal = "Real" smtType KFloat = "(_ FloatingPoint 8 24)" smtType KDouble = "(_ FloatingPoint 11 53)" -smtType (KFP eb sb) = "(_ FloatingPoint " ++ show eb ++ " " ++ show sb ++ ")" +smtType (KFP eb sb) = "(_ FloatingPoint " <> showText eb <> " " <> showText sb <> ")" smtType KString = "String" smtType KChar = "String" -smtType (KList k) = "(Seq " ++ smtType k ++ ")" -smtType (KSet k) = "(Array " ++ smtType k ++ " Bool)" -smtType (KApp s ks) = kindParenStr $ unwords (s : map smtType ks) -smtType (KADT s pks _) = kindParenStr $ unwords (s : map (smtType . snd) pks) +smtType (KList k) = "(Seq " <> smtType k <> ")" +smtType (KSet k) = "(Array " <> smtType k <> " Bool)" +smtType (KApp s ks) = kindParen $ T.unwords (T.pack s : map smtType ks) +smtType (KADT s pks _) = kindParen $ T.unwords (T.pack s : map (smtType . snd) pks) smtType (KTuple []) = "SBVTuple0" -smtType (KTuple kinds) = "(SBVTuple" ++ show (length kinds) ++ " " ++ unwords (smtType <$> kinds) ++ ")" +smtType (KTuple kinds) = "(SBVTuple" <> showText (length kinds) <> " " <> T.unwords (smtType <$> kinds) <> ")" smtType KRational = "SBVRational" -smtType (KArray k1 k2) = "(Array " ++ smtType k1 ++ " " ++ smtType k2 ++ ")" +smtType (KArray k1 k2) = "(Array " <> smtType k1 <> " " <> smtType k2 <> ")" instance Eq G.DataType where a == b = G.tyconUQname (G.dataTypeName a) == G.tyconUQname (G.dataTypeName b) diff --git a/Data/SBV/Core/Model.hs b/Data/SBV/Core/Model.hs --- a/Data/SBV/Core/Model.hs +++ b/Data/SBV/Core/Model.hs @@ -20,6 +20,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -27,7 +28,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Model ( Mergeable(..), Equality(..), EqSymbolic(..), OrdSymbolic(..) @@ -69,7 +70,7 @@ where import Control.Applicative (ZipList(ZipList)) -import Control.Monad (when, unless, mplus, replicateM, forM_) +import Control.Monad (when, unless, mplus, replicateM) import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Control.Exception as C @@ -78,10 +79,7 @@ import qualified GHC.Generics as G import GHC.Stack -import GHC.TypeLits -#if MIN_VERSION_base(4,18,0) - hiding(SChar) -#endif +import GHC.TypeLits hiding(SChar) import Data.Array (Array, Ix, elems, bounds, rangeSize) import qualified Data.Array as DA (listArray) @@ -115,9 +113,10 @@ import qualified Test.QuickCheck as QC (quickCheckResult, counterexample) import qualified Test.QuickCheck.Monadic as QC (monadicIO, run, assert, pre, monitor) -import qualified Data.Foldable as F (toList) +import qualified Data.Foldable as F (toList, for_) import qualified Data.Map.Strict as Map import qualified Data.Sequence as Seq +import qualified Data.Text as T import Data.SBV.Core.AlgReals import Data.SBV.Core.Sized @@ -434,8 +433,9 @@ instance (SymVal a, SymVal b) => SymVal (a, b) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b))) literal (v1, v2) = mkCVTup 2 (kindOf (Proxy @(a, b))) [toCV v1, toCV v2] - fromCV cv = let ~[v1, v2] = fromCVTup 2 cv - in (fromCV v1, fromCV v2) + fromCV cv = case fromCVTup 2 cv of + [v1, v2] -> (fromCV v1, fromCV v2) + res -> error $ "Data.SBV.SymVal-Tuple2: Unexpected result: " ++ show res minMaxBound = Nothing @@ -443,48 +443,54 @@ instance (SymVal a, SymVal b, SymVal c) => SymVal (a, b, c) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c))) literal (v1, v2, v3) = mkCVTup 3 (kindOf (Proxy @(a, b, c))) [toCV v1, toCV v2, toCV v3] - fromCV cv = let ~[v1, v2, v3] = fromCVTup 3 cv - in (fromCV v1, fromCV v2, fromCV v3) + fromCV cv = case fromCVTup 3 cv of + [v1, v2, v3] -> (fromCV v1, fromCV v2, fromCV v3) + res -> error $ "Data.SBV.SymVal-Tuple3: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 4-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d) => SymVal (a, b, c, d) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d))) literal (v1, v2, v3, v4) = mkCVTup 4 (kindOf (Proxy @(a, b, c, d))) [toCV v1, toCV v2, toCV v3, toCV v4] - fromCV cv = let ~[v1, v2, v3, v4] = fromCVTup 4 cv - in (fromCV v1, fromCV v2, fromCV v3, fromCV v4) + fromCV cv = case fromCVTup 4 cv of + [v1, v2, v3, v4] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4) + res -> error $ "Data.SBV.SymVal-Tuple4: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 5-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e) => SymVal (a, b, c, d, e) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e))) literal (v1, v2, v3, v4, v5) = mkCVTup 5 (kindOf (Proxy @(a, b, c, d, e))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5] - fromCV cv = let ~[v1, v2, v3, v4, v5] = fromCVTup 5 cv - in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5) + fromCV cv = case fromCVTup 5 cv of + [v1, v2, v3, v4, v5] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5) + res -> error $ "Data.SBV.SymVal-Tuple5: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 6-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f) => SymVal (a, b, c, d, e, f) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f))) literal (v1, v2, v3, v4, v5, v6) = mkCVTup 6 (kindOf (Proxy @(a, b, c, d, e, f))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5, toCV v6] - fromCV cv = let ~[v1, v2, v3, v4, v5, v6] = fromCVTup 6 cv - in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6) + fromCV cv = case fromCVTup 6 cv of + [v1, v2, v3, v4, v5, v6] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6) + res -> error $ "Data.SBV.SymVal-Tuple6: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 7-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g) => SymVal (a, b, c, d, e, f, g) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f, g))) literal (v1, v2, v3, v4, v5, v6, v7) = mkCVTup 7 (kindOf (Proxy @(a, b, c, d, e, f, g))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5, toCV v6, toCV v7] - fromCV cv = let ~[v1, v2, v3, v4, v5, v6, v7] = fromCVTup 7 cv - in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7) + fromCV cv = case fromCVTup 7 cv of + [v1, v2, v3, v4, v5, v6, v7] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7) + res -> error $ "Data.SBV.SymVal-Tuple7: Unexpected result: " ++ show res minMaxBound = Nothing -- | SymVal for 8-tuples instance (SymVal a, SymVal b, SymVal c, SymVal d, SymVal e, SymVal f, SymVal g, SymVal h) => SymVal (a, b, c, d, e, f, g, h) where mkSymVal = genMkSymVar (kindOf (Proxy @(a, b, c, d, e, f, g, h))) literal (v1, v2, v3, v4, v5, v6, v7, v8) = mkCVTup 8 (kindOf (Proxy @(a, b, c, d, e, f, g, h))) [toCV v1, toCV v2, toCV v3, toCV v4, toCV v5, toCV v6, toCV v7, toCV v8] - fromCV cv = let ~[v1, v2, v3, v4, v5, v6, v7, v8] = fromCVTup 8 cv - in (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7, fromCV v8) + fromCV cv = case fromCVTup 8 cv of + [v1, v2, v3, v4, v5, v6, v7, v8] -> (fromCV v1, fromCV v2, fromCV v3, fromCV v4, fromCV v5, fromCV v6, fromCV v7, fromCV v8) + res -> error $ "Data.SBV.SymVal-Tuple8: Unexpected result: " ++ show res minMaxBound = Nothing instance IsString SString where @@ -845,7 +851,7 @@ -- | Generalization of 'Data.SBV.solve' solve :: MonadSymbolic m => [SBool] -> m SBool -solve = return . sAnd +solve = pure . sAnd -- | Convert an SReal to an SInteger. That is, it computes the -- largest integer @n@ that satisfies @sIntegerToSReal n <= r@ @@ -861,9 +867,10 @@ where y st = do xsv <- sbvToSV st x newExpr st KUnbounded (SBVApp (KindCast KReal KUnbounded) [xsv]) --- | Convert an SReal to an SInteger, truncating version. +-- | Convert an SReal to an SInteger, truncating version. Truncate simply chops of the +-- fractional part, essentially rounding towards zero. sRealToSIntegerTruncate :: SReal -> SInteger -sRealToSIntegerTruncate x = ite (x .< 0) (sRealToSInteger x) (- (sRealToSInteger (- x))) +sRealToSIntegerTruncate x = ite (x .>= 0) (sRealToSInteger x) (- sRealToSInteger (-x)) -- | label: Label the result of an expression. This is essentially a no-op, but useful as it generates a comment in the generated C/SMT-Lib code. -- Note that if the argument is a constant, then the label is dropped completely, per the usual constant folding strategy. Compare this to 'observe' @@ -892,8 +899,8 @@ = SBV $ SVal k $ Right $ cache r where k = kindOf x r st = do xsv <- sbvToSV st (label ("Observing: " ++ m) x) - recordObservable st m (cond . fromCV) xsv - return xsv + recordObservable st (T.pack m) (cond . fromCV) xsv + pure xsv -- | Observe the value of an expression, unconditionally. See 'observeIf' for a generalized version. observe :: SymVal a => String -> SBV a -> SBV a @@ -1366,10 +1373,10 @@ let curVerifying = measuresBeingVerified (tpOptions cfg) cfg' = cfg{tpOptions = (tpOptions cfg){measuresBeingVerified = Set.insert funcNm curVerifying}} - debug cfg ["[MEASURE] " ++ funcNm ++ ": verifying with " ++ show (length helpers) ++ " helper(s)" - ++ if Set.null curVerifying then "" else ", already verifying: " ++ show (Set.toList curVerifying)] + debug cfg ["[MEASURE] " <> T.pack funcNm <> ": verifying with " <> showText (length helpers) <> " helper(s)" + <> if Set.null curVerifying then "" else ", already verifying: " <> showText (Set.toList curVerifying)] axioms <- mapM (`runMeasureHelper` cfg') helpers - debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ show (length axioms) ++ " helper axiom(s) collected, checking measure"] + debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> showText (length axioms) <> " helper axiom(s) collected, checking measure"] result <- checkMeasure cfg funcNm False info meval axioms let prettyNm = prettyFuncNm funcNm case result of @@ -1417,7 +1424,7 @@ cfgNonNeg = cfgIn{transcript = addSuffix "nonNeg" <$> transcript cfgIn} cfgDecrease = cfgIn{transcript = addSuffix "decrease" <$> transcript cfgIn} barFuncNm = barify funcNm - recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == barFuncNm] + recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == T.pack barFuncNm] if null recCalls then pure MeasureOK @@ -1494,7 +1501,7 @@ mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs k = kindOf rcSV -- Create the actual function call: f(mapped_args) - actualSV <- newExpr st k (SBVApp (Uninterpreted barFuncNm) mappedArgs) + actualSV <- newExpr st k (SBVApp (Uninterpreted (T.pack barFuncNm)) mappedArgs) -- Assert fresh_var == f(mapped_args) let freshSVal = SVal k (Right (cache (const (pure freshSV)))) actualSVal = SVal k (Right (cache (const (pure actualSV)))) @@ -1542,9 +1549,9 @@ let curVerifying = measuresBeingVerified (tpOptions cfg) cfg' = cfg{tpOptions = (tpOptions cfg){measuresBeingVerified = Set.insert funcNm curVerifying}} - debug cfg ["[MEASURE] " ++ funcNm ++ " (contract): verifying with " ++ show (length helpers) ++ " helper(s)"] + debug cfg ["[MEASURE] " <> T.pack funcNm <> " (contract): verifying with " <> showText (length helpers) <> " helper(s)"] axioms <- mapM (`runMeasureHelper` cfg') helpers - debug cfg ["[MEASURE] " ++ funcNm ++ " (contract): " ++ show (length axioms) ++ " helper axiom(s) collected, checking measure+contract"] + debug cfg ["[MEASURE] " <> T.pack funcNm <> " (contract): " <> showText (length axioms) <> " helper axiom(s) collected, checking measure+contract"] result <- checkMeasureWithContract cfg funcNm False info meval ceval axioms let prettyNm = prettyFuncNm funcNm case result of @@ -1587,7 +1594,7 @@ cfgNonNeg = cfgIn{transcript = addSuffix "nonNeg" <$> transcript cfgIn} cfgDecrease = cfgIn{transcript = addSuffix "decrease" <$> transcript cfgIn} barFuncNm = barify funcNm - recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == barFuncNm] + recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList liAssignments, nm == T.pack barFuncNm] if null recCalls then pure MeasureOK @@ -1658,7 +1665,7 @@ -- with the call's arguments substituted for the formal parameters. -- This gives the solver base-case behavior without assuming totality. let dagList = F.toList liAssignments - liftIO $ forM_ recCalls $ \(rcSV, callArgSVs) -> do + liftIO $ F.for_ recCalls $ \(rcSV, callArgSVs) -> do let -- Map the call's arguments through svMap to get the fresh session SVs mappedCallArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs -- Build the initial map for the unfolded body: formal params -> call args @@ -1681,11 +1688,11 @@ -- IH contract: for each recursive call, assume the contract holds on its result. -- This is sound because we also prove measure decrease at each call site. - liftIO $ forM_ recCalls $ \(rcSV, callArgSVs) -> do - let mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs - argSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) mappedArgs - freshCallSV = Map.findWithDefault rcSV rcSV svMap - freshResult = SVal (kindOf rcSV) (Right (cache (const (pure freshCallSV)))) + liftIO $ F.for_ recCalls $ \(rcSV, callArgSVs) -> do + let mappedArgs = map (\sv -> Map.findWithDefault sv sv svMap) callArgSVs + argSVals = map (\sv -> SVal (kindOf sv) (Right (cache (\_ -> pure sv)))) mappedArgs + freshCallSV = Map.findWithDefault rcSV rcSV svMap + freshResult = SVal (kindOf rcSV) (Right (cache (const (pure freshCallSV)))) contractHolds = applyC argSVals freshResult internalConstraint st False [] (unSBV contractHolds) @@ -1734,7 +1741,7 @@ verifyGuardedness :: SMTConfig -> String -> LambdaInfo -> IO () verifyGuardedness cfg funcNm info | isGuardedRecursive (Set.singleton (barify funcNm)) info - = debug cfg ["[MEASURE] " ++ funcNm ++ ": productive (all recursive calls are guarded by constructors)"] + = debug cfg ["[MEASURE] " <> T.pack funcNm <> ": productive (all recursive calls are guarded by constructors)"] | True = error $ unlines [ "" @@ -1755,7 +1762,7 @@ isGuardedRecursive barFuncNms LambdaInfo{liAssignments} = all isGuarded recCallSVs where dagList = F.toList liAssignments - recCallSVs = [sv | (sv, SBVApp (Uninterpreted nm) _) <- dagList, nm `Set.member` barFuncNms] + recCallSVs = [sv | (sv, SBVApp (Uninterpreted nm) _) <- dagList, nm `Set.member` Set.map T.pack barFuncNms] -- Build a map from SV to the set of operations that consume it consumers :: Map.Map SV [(SV, Op)] @@ -1823,7 +1830,7 @@ SBV $ SVal KUnbounded $ Right $ cache $ \st -> do ensureADTSizeDefined st sizeName adtKind ctors s <- sbvToSV st (SBV (svs !! i)) - newExpr st KUnbounded (SBVApp (Uninterpreted sizeName) [s]), Just i)] + newExpr st KUnbounded (SBVApp (Uninterpreted (T.pack sizeName)) [s]), Just i)] _ -> [] mkTupleComponent :: Int -> Int -> (Int, Kind) -> [(String, [SVal] -> SInteger, Maybe Int)] @@ -1906,7 +1913,7 @@ defs <- readIORef (rDefns st) unless (Map.member sizeName defs) $ do let argNm = "x" - smtArgType = smtType adtKind + smtArgType = T.unpack (smtType adtKind) -- Build the SMT-Lib body for the size function body = buildBody ctors @@ -1928,8 +1935,8 @@ smtSum (x:xs) = "(+ " ++ x ++ " " ++ smtSum xs ++ ")" smtSum [] = "0" - paramStr = "((" ++ argNm ++ " " ++ smtArgType ++ "))" - smtDef = SMTDef KUnbounded [sizeName] (Just paramStr) (\n -> replicate n ' ' ++ body) + paramStr = T.pack $ "((" ++ argNm ++ " " ++ smtArgType ++ "))" + smtDef = SMTDef KUnbounded [sizeName] (Just paramStr) (\n -> T.pack (replicate n ' ' ++ body)) sbvTy = SBVType [adtKind, KUnbounded] modifyIORef' (rDefns st) (Map.insert sizeName (smtDef, sbvTy)) @@ -1955,7 +1962,7 @@ asgns = F.toList liAssignments defMap = Map.fromList asgns - recCalls = [args | (_, SBVApp (Uninterpreted nm) args) <- asgns, nm == barFuncNm] + recCalls = [args | (_, SBVApp (Uninterpreted nm) args) <- asgns, nm == T.pack barFuncNm] checkCall callArgs | paramIdx < length callArgs = isProperSubTerm (callArgs !! paramIdx) @@ -1974,33 +1981,33 @@ autoGuess :: SMTConfig -> String -> LambdaInfo -> IO (Maybe MeasureEval) autoGuess cfg funcNm info = do let barFuncNm = barify funcNm - recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList (liAssignments info), nm == barFuncNm] + recCalls = [(sv, args) | (sv, SBVApp (Uninterpreted nm) args) <- F.toList (liAssignments info), nm == T.pack barFuncNm] allUIs = [(nm, length args) | (_, SBVApp (Uninterpreted nm) args) <- F.toList (liAssignments info)] - debug cfg ["[MEASURE] " ++ funcNm ++ ": barified = " ++ show barFuncNm] - debug cfg ["[MEASURE] " ++ funcNm ++ ": Uninterpreted ops in DAG: " ++ show allUIs] - debug cfg ["[MEASURE] " ++ funcNm ++ ": recursive calls found = " ++ show (length recCalls)] + debug cfg ["[MEASURE] " <> T.pack funcNm <> ": barified = " <> showText barFuncNm] + debug cfg ["[MEASURE] " <> T.pack funcNm <> ": Uninterpreted ops in DAG: " <> showText allUIs] + debug cfg ["[MEASURE] " <> T.pack funcNm <> ": recursive calls found = " <> showText (length recCalls)] go candidates where candidates = guessMeasures (liParams info) go [] = pure Nothing go ((desc, m, mbIdx):ms) = do let skipNonNeg = "sbv.dt.size." `isPrefixOf` desc - debug cfg ["[MEASURE] " ++ funcNm ++ ": trying " ++ desc] + debug cfg ["[MEASURE] " <> T.pack funcNm <> ": trying " <> T.pack desc] -- For ADT size measures, try syntactic sub-term check first. -- This avoids calling the solver, which can hang on recursive -- define-fun-rec definitions. result <- case mbIdx of Just idx | isStructurallyDecreasing funcNm info idx -> do - debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ desc ++ " -> OK (structural recursion)"] + debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " -> OK (structural recursion)"] pure MeasureOK _ -> checkMeasure cfg funcNm skipNonNeg info m [] case result of - MeasureOK -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ desc ++ " -> OK"] + MeasureOK -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " -> OK"] pure (Just m) - MeasureNotNonNeg r -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ desc ++ " failed non-negativity: " ++ show r] - debug cfg ["[MEASURE] " ++ funcNm ++ ": trying next candidate.."] + MeasureNotNonNeg r -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " failed non-negativity: " <> showText r] + debug cfg ["[MEASURE] " <> T.pack funcNm <> ": trying next candidate.."] go ms - MeasureNotDecreasing r -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": " ++ desc ++ " failed strict decrease: " ++ show r] - debug cfg ["[MEASURE] " ++ funcNm ++ ": trying next candidate.."] + MeasureNotDecreasing r -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": " <> T.pack desc <> " failed strict decrease: " <> showText r] + debug cfg ["[MEASURE] " <> T.pack funcNm <> ": trying next candidate.."] go ms -- | Auto-guess a termination measure, or fail with a helpful error message. @@ -2063,9 +2070,9 @@ -- Remove verified members from rFuncLambdaInfos so that subsequent closures -- for the same group (registered by other members) find insufficient infos and skip. modifyIORef' (rFuncLambdaInfos st) (\m -> foldl' (flip Map.delete) m plainMembers) - else do debug cfg ["[MEASURE] " ++ funcNm ++ ": mutual group already verified, skipping"] + else do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": mutual group already verified, skipping"] modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm) - _ -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": not in a multi-member cycle, skipping mutual check"] + _ -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": not in a multi-member cycle, skipping mutual check"] modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm) -- | Reject mutual recursion for contract-based functions. Deferred to SCC computation time @@ -2089,7 +2096,7 @@ , "*** Please use smtFunction or smtFunctionWithMeasure for mutual recursion groups." , "" ] - _ -> debug cfg ["[MEASURE] " ++ funcNm ++ ": not in a multi-member cycle, skipping mutual contract check"] + _ -> debug cfg ["[MEASURE] " <> T.pack funcNm <> ": not in a multi-member cycle, skipping mutual contract check"] -- | Check that all members of a mutual recursion group marked as productive are guarded-recursive, -- considering cross-calls as well as self-calls. @@ -2110,10 +2117,11 @@ if Map.size infos >= 2 then do let barNames = Set.fromList members memberNamesStr = intercalate ", " (map prettyFuncNm plainMembers) - debug cfg ["[MEASURE] Checking mutual productive group: {" ++ memberNamesStr ++ "}"] + debug cfg ["[MEASURE] Checking mutual productive group: {" <> T.pack memberNamesStr <> "}"] let failed = [(pnm, info) | (pnm, info) <- Map.toList infos, not (isGuardedRecursive barNames info)] case failed of [] -> do debug cfg ["[MEASURE] Mutual productive group: all members are guarded"] + modifyIORef' (rFuncLambdaInfos st) (\m -> foldl' (flip Map.delete) m plainMembers) _ -> error $ unlines $ [ "" @@ -2127,9 +2135,9 @@ , "*** Every recursive call (self or cross) must be a direct argument to a data constructor." , "" ] - else do debug cfg ["[MEASURE] " ++ funcNm ++ ": mutual productive group already verified, skipping"] + else do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": mutual productive group already verified, skipping"] modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm) - _ -> do debug cfg ["[MEASURE] " ++ funcNm ++ ": not in a multi-member cycle, skipping mutual productive check"] + _ -> do debug cfg ["[MEASURE] " <> T.pack funcNm <> ": not in a multi-member cycle, skipping mutual productive check"] modifyIORef' (rFuncLambdaInfos st) (Map.delete funcNm) -- | Check termination for a mutual recursion group. Each function in the group @@ -2141,7 +2149,7 @@ checkMutualGroup cfg members mbMeasure = do let memberNames = Map.keys members memberNamesStr = intercalate ", " (map prettyFuncNm memberNames) - debug cfg ["[MEASURE] Checking mutual recursion group: {" ++ memberNamesStr ++ "}"] + debug cfg ["[MEASURE] Checking mutual recursion group: {" <> T.pack memberNamesStr <> "}"] -- If a user-provided measure is given, try it first let memberList = Map.toList members @@ -2210,18 +2218,18 @@ where go [] = pure Nothing go ((desc, m, _mbIdx):rest) = do - debug cfg ["[MEASURE] Mutual group: trying measure " ++ desc ++ " for all members"] + debug cfg ["[MEASURE] Mutual group: trying measure " <> T.pack desc <> " for all members"] -- Try the same measure for all members. Catch exceptions from kind mismatches -- (e.g., applying abs to a list parameter) and treat them as failure. let memberList = [(nm, info) | (nm, info, _) <- memberInfos] result <- C.try $ checkMutualMeasure cfg memberList m case result of - Right True -> do debug cfg ["[MEASURE] Mutual group: measure " ++ desc ++ " works for all members"] + Right True -> do debug cfg ["[MEASURE] Mutual group: measure " <> T.pack desc <> " works for all members"] pure (Just m) - Right False -> do debug cfg ["[MEASURE] Mutual group: measure " ++ desc ++ " failed, trying next"] + Right False -> do debug cfg ["[MEASURE] Mutual group: measure " <> T.pack desc <> " failed, trying next"] go rest Left (e :: C.SomeException) -> do - debug cfg ["[MEASURE] Mutual group: measure " ++ desc ++ " incompatible: " ++ show e] + debug cfg ["[MEASURE] Mutual group: measure " <> T.pack desc <> " incompatible: " <> showText e] go rest -- | Verify that a given measure works for all functions in a mutual recursion group. @@ -2238,7 +2246,7 @@ -- Find all calls to any member of the mutual group let allGroupCalls = [(sv, args) | (sv, SBVApp (Uninterpreted calleeNm) args) <- F.toList liAssignments - , calleeNm `Set.member` groupBarNames + , calleeNm `Set.member` Set.map T.pack groupBarNames ] if null allGroupCalls @@ -2304,13 +2312,13 @@ pure $ sAnd obligations :: Symbolic SBool) case decResult of ThmResult Unsatisfiable{} -> do - debug cfgIn ["[MEASURE] Mutual group: decrease verified for " ++ funcNm] + debug cfgIn ["[MEASURE] Mutual group: decrease verified for " <> T.pack funcNm] go rest _ -> do - debug cfgIn ["[MEASURE] Mutual group: decrease failed for " ++ funcNm ++ ": " ++ show decResult] + debug cfgIn ["[MEASURE] Mutual group: decrease failed for " <> T.pack funcNm <> ": " <> showText decResult] pure False _ -> do - debug cfgIn ["[MEASURE] Mutual group: non-negativity failed for " ++ funcNm] + debug cfgIn ["[MEASURE] Mutual group: non-negativity failed for " <> T.pack funcNm] pure False -- | Pretty-print a function name: turn @"insert @(SBV Integer -> SBV [Integer])"@ into @"insert :: SBV Integer -> SBV [Integer]"@ @@ -2340,7 +2348,7 @@ replayDAG cfg st recFuncNames definedFuncs startMap dag = do let n = length dag let nms = intercalate ", " (map unBar (Set.toList recFuncNames)) - debug cfg ["[MEASURE] replayDAG {" ++ nms ++ "}: replaying " ++ show n ++ " node(s)"] + debug cfg ["[MEASURE] replayDAG {" <> T.pack nms <> "}: replaying " <> showText n <> " node(s)"] go startMap dag where -- Map an SV through the svMap. If it's not found, it's an external captured variable -- (e.g., from a higher-order function's closure). Create a fresh unconstrained variable @@ -2361,9 +2369,9 @@ (mappedArgs, svMap') <- mapArgs svMap args newSV' <- case op of -- For recursive calls (self or mutual), create a fresh uninterpreted value instead of replaying - Uninterpreted nm | nm `Set.member` recFuncNames -> newInternalVariable st (kindOf sv) + Uninterpreted nm | nm `Set.member` Set.map T.pack recFuncNames -> newInternalVariable st (kindOf sv) -- For calls to other defined functions (e.g., partition), replay properly - Uninterpreted nm | nm `Set.member` definedFuncs -> do + Uninterpreted nm | nm `Set.member` Set.map T.pack definedFuncs -> do let mappedOp = mapOpSVs (\a -> Map.findWithDefault a a svMap') op newExpr st (kindOf sv) (SBVApp mappedOp mappedArgs) -- For everything else that's Uninterpreted (free functions, sentinels, etc.), @@ -3409,7 +3417,7 @@ -- Quickcheck interface instance (SymVal a, Arbitrary a) => Arbitrary (SBV a) where - arbitrary = literal `fmap` arbitrary + arbitrary = literal <$> arbitrary -- | Symbolic conditionals are modeled by the 'Mergeable' class, describing -- how to merge the results of an if-then-else call with a symbolic test. SBV @@ -3487,7 +3495,7 @@ | Just mustHold <- unliteral cond = if mustHold then x - else error $ show $ SafeResult ((locInfo . getCallStack) `fmap` cs, msg, Satisfiable defaultSMTCfg (SMTModel [] Nothing [] [])) + else error $ show $ SafeResult (locInfo . getCallStack <$> cs, msg, Satisfiable defaultSMTCfg (SMTModel [] Nothing [] [])) | True = SBV $ SVal k $ Right $ cache r where k = kindOf x @@ -3498,7 +3506,7 @@ mustNeverHappen = pc .&& sNot cond cnd <- sbvToSV st mustNeverHappen addAssertion st cs msg cnd - return xsv + pure xsv locInfo ps = intercalate ",\n " (map loc ps) where loc (f, sl) = concat [srcLocFile sl, ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f] @@ -3535,7 +3543,7 @@ r st = do sws <- mapM (sbvToSV st) xs swe <- sbvToSV st err if all (== swe) sws -- off-chance that all elts are the same. Note that this also correctly covers the case when list is empty. - then return swe + then pure swe else do idx <- getTableIndex st kInd kElt sws swi <- sbvToSV st ind let len = length xs @@ -3595,7 +3603,8 @@ symbolicMerge _ _ a b = cannotMerge "'Maybe' values" ("Branches produce different constructors: " ++ show (k a, k b)) "Instead of an option type, try using a valid bit to indicate when a result is valid." - where k Nothing = "Nothing" + where k :: Maybe a -> String + k Nothing = "Nothing" k _ = "Just" -- Either @@ -3605,7 +3614,8 @@ symbolicMerge _ _ a b = cannotMerge "'Either' values" ("Branches produce different constructors: " ++ show (k a, k b)) "Consider using a product type by a tag instead." - where k (Left _) = "Left" + where k :: Either a b -> String + k (Left _) = "Left" k (Right _) = "Right" -- Arrays @@ -3615,7 +3625,8 @@ | True = cannotMerge "'Array' values" ("Branches produce different ranges: " ++ show (k ba, k bb)) "Consider using SBV's native 'SArray' abstraction." - where [ba, bb] = map bounds [a, b] + where ba = bounds a + bb = bounds b k = rangeSize -- Functions @@ -3975,11 +3986,11 @@ sbv2smt a = sbvFun2smt (\(_ :: SBVs RNil) -> a) sbvDefineValue nm mbArgs k = - sbvDefineValueFun nm mbArgs SymValsNil (fmap const k) SBVsNil + sbvDefineValueFun nm mbArgs SymValsNil (const <$> k) SBVsNil - mkADTConstructor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTConstructor nm k)) Nothing $ UIFree True in v - mkADTTester nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTTester nm k)) Nothing $ UIFree True in v - mkADTAccessor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTAccessor nm k)) Nothing $ UIFree True in v + mkADTConstructor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTConstructor (T.pack nm) k)) Nothing $ UIFree True in v + mkADTTester nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTTester (T.pack nm) k)) Nothing $ UIFree True in v + mkADTAccessor nm = let k = resKind (kindOf v); v = sbvDefineValue (UIADT (ADTAccessor (T.pack nm) k)) Nothing $ UIFree True in v smtFunctionDef nm msr v = sbvDefineValue (UIGiven (atProxy (Proxy @a) nm)) Nothing $ UIFun (v, \st fk -> do @@ -3988,12 +3999,13 @@ -- Record LambdaInfo for SCC-aware mutual recursion checking modifyIORef' (rFuncLambdaInfos st) (Map.insert funcNm info) let barFuncNm = barify funcNm + tBarFuncNm = T.pack barFuncNm isSelfRec = any (\(_, SBVApp op _) -> case op of - Uninterpreted n -> n == barFuncNm + Uninterpreted n -> n == tBarFuncNm _ -> False) (liAssignments info) hasCrossRefs = any (\(_, SBVApp op _) -> case op of - Uninterpreted n -> n /= barFuncNm + Uninterpreted n -> n /= tBarFuncNm _ -> False) (liAssignments info) case msr of @@ -4005,6 +4017,7 @@ modifyIORef' (rMeasureChecks st) ((funcNm, False, \cfg -> checkMutualFromState cfg funcNm st Nothing) :) pure def + HasMeasure eval helpers -> do when isSelfRec $ modifyIORef' (rMeasureChecks st) @@ -4013,6 +4026,7 @@ modifyIORef' (rMeasureChecks st) ((funcNm, False, \cfg -> checkMutualFromState cfg funcNm st (Just eval)) :) pure def + HasContract eval ceval helpers -> do when hasCrossRefs $ modifyIORef' (rMeasureChecks st) @@ -4020,6 +4034,7 @@ modifyIORef' (rMeasureChecks st) ((funcNm, False, \cfg -> verifyMeasureWithContract cfg funcNm info eval ceval helpers) :) pure def + Productive -> do when isSelfRec $ modifyIORef' (rMeasureChecks st) @@ -4028,8 +4043,9 @@ modifyIORef' (rMeasureChecks st) ((funcNm, True, \cfg -> checkMutualProductiveFromState cfg funcNm st) :) pure def + Unverified -> do modifyIORef' (rNoTermCheckFunctions st) (Set.insert nm) - debug (stCfg st) ["[MEASURE] " ++ funcNm ++ ": no termination check (smtFunctionNoTermination)"] + debug (stCfg st) ["[MEASURE] " <> T.pack funcNm <> ": no termination check (smtFunctionNoTermination)"] pure def) @@ -4175,7 +4191,7 @@ = do st <- mkNewState defaultSMTCfg (LambdaGen (Just 0)) s <- lambdaStr st TopLevel (kindOf a) a pure $ intercalate "\n" [ "; Automatically generated by SBV. Do not modify!" - , "; Type: " ++ smtType (kindOf a) + , "; Type: " ++ T.unpack (smtType (kindOf a)) , show s ] sbvFun2smt fn = defs2smt (\args -> fn args .== fn args) @@ -4207,7 +4223,7 @@ sbvDefineValueFun nm mbArgs insts uiKind args a = sbvDefineValueFun nm mbArgs (SymValsCons insts) - (fmap (\f (SBVsCons xs x) -> f xs x) uiKind) (SBVsCons args a) + ((\f (SBVsCons xs x) -> f xs x) <$> uiKind) (SBVsCons args a) registerFunction f = do let k = kindOf (Proxy @a) st <- symbolicEnv @@ -4330,7 +4346,7 @@ -- | Generalization of 'Data.SBV.assertWithPenalty' assertWithPenalty :: MonadSymbolic m => String -> SBool -> Penalty -> m () -assertWithPenalty nm o p = addSValOptGoal $ unSBV `fmap` AssertWithPenalty nm o p +assertWithPenalty nm o p = addSValOptGoal $ unSBV <$> AssertWithPenalty nm o p -- | Class of metrics we can optimize for. Currently, booleans, -- bounded signed/unsigned bit-vectors, unbounded integers, @@ -4366,13 +4382,13 @@ msMinimize :: (MonadSymbolic m, SolverContext m) => String -> SBV a -> m () msMinimize nm o = do let nm' = annotateForMS (Proxy @a) nm when (nm' /= nm) $ sObserve nm (unSBV o) - addSValOptGoal $ unSBV `fmap` Minimize nm' (toMetricSpace o) + addSValOptGoal $ unSBV <$> Minimize nm' (toMetricSpace o) -- | Maximizing a metric space msMaximize :: (MonadSymbolic m, SolverContext m) => String -> SBV a -> m () msMaximize nm o = do let nm' = annotateForMS (Proxy @a) nm when (nm' /= nm) $ sObserve nm (unSBV o) - addSValOptGoal $ unSBV `fmap` Maximize nm' (toMetricSpace o) + addSValOptGoal $ unSBV <$> Maximize nm' (toMetricSpace o) -- if MetricSpace is the same, we can give a default definition default toMetricSpace :: (a ~ MetricSpace a) => SBV a -> SBV (MetricSpace a) @@ -4453,7 +4469,7 @@ QC.pre cond unless (r || null modelVals) $ QC.monitor (QC.counterexample (complain modelVals)) QC.assert r - where test = do (r, Result{resTraces=tvals, resObservables=ovals, resConsts=(_, cs), resConstraints=cstrs, resUIConsts=unints}) <- + where test = do (r, Result{resTraces=tvals, resObservables=ovals, resConsts=(_, cs), resConstraints=cstrs, resUIConsts=unints}) <- C.catch (runSymbolic defaultSMTCfg (Concrete Nothing) prop) (\(e :: C.SomeException) -> cantQuickCheck (show e)) @@ -4469,7 +4485,7 @@ case map fst unints of [] -> case unliteral r of Nothing -> cantQuickCheck "The result did not evaluate to a concrete value" - Just b -> return (cond, b, tvals ++ mapMaybe getObservable ovals) + Just b -> pure (cond, b, tvals ++ mapMaybe getObservable ovals) uis -> cantQuickCheck $ "Uninterpreted constants remain: " ++ unwords uis complain qcInfo = showModel defaultSMTCfg (SMTModel [] Nothing qcInfo []) @@ -4500,14 +4516,14 @@ -- | Quick check an SBV property. Note that a regular @quickCheck@ call will work just as -- well. Use this variant if you want to receive the boolean result. sbvQuickCheck :: Symbolic SBool -> IO Bool -sbvQuickCheck prop = QC.isSuccess `fmap` QC.quickCheckResult prop +sbvQuickCheck prop = QC.isSuccess <$> QC.quickCheckResult prop -- Quickcheck interface on dynamically-typed values. A run-time check -- ensures that the value has boolean type. instance Testable (Symbolic SVal) where property m = property $ do s <- m when (kindOf s /= KBool) $ error "Cannot quickcheck non-boolean value" - return (SBV s :: SBool) + pure (SBV s :: SBool) -- | Explicit sharing combinator. The SBV library has internal caching/hash-consing mechanisms -- built in, based on Andy Gill's type-safe observable sharing technique (see: ). @@ -4518,7 +4534,7 @@ slet x f = SBV $ SVal k $ Right $ cache r where k = kindOf (Proxy @b) r st = do xsv <- sbvToSV st x - let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (return xsv)))) + let xsbv = SBV $ SVal (kindOf x) (Right (cache (const (pure xsv)))) res = f xsbv sbvToSV st res @@ -4732,15 +4748,7 @@ -> f -- The higher-order argument. We're very generic here! -> (a -> SBV b) -- The ho-function we're modeling -> a -> SBV b -- The resulting function, that can be used as is, and will be rendered in SMTLib without unfolding -smtHOFunction nm f hof arg = SBV $ SVal (kindOf (Proxy @(SBV b))) $ Right $ cache r - where r st = do SMTLambda lam <- lambdaStr st HigherOrderArg (resKindOf (kindOf (Proxy @f))) f - let uniqLen = firstifyUniqueLen $ stCfg st - uniq = take uniqLen (BC.unpack (B.encode (hash (BC.pack (unwords (words lam)))))) - sbvToSV st (smtFunctionDef (atProxy (Proxy @f) nm <> "_" <> uniq) AutoMeasure hof arg) - - -- we get the functions as arrays here, so chase to find the result - resKindOf (KArray _ k) = resKindOf k - resKindOf k = k +smtHOFunction nm f = smtHOFunctionGen nm f AutoMeasure -- | Like 'smtHOFunction', but with an explicit termination measure. Use this when the -- auto-guess measure doesn't work for a higher-order recursive function. @@ -4760,17 +4768,39 @@ -> MeasureOf (a -> SBV b) r -- ^ Termination measure -> (a -> SBV b) -- ^ The ho-function we're modeling -> a -> SBV b -- ^ The resulting function -smtHOFunctionWithMeasure nm f msr hof arg = SBV $ SVal (kindOf (Proxy @(SBV b))) $ Right $ cache r - where r st = do SMTLambda lam <- lambdaStr st HigherOrderArg (resKindOf (kindOf (Proxy @f))) f - let uniqLen = firstifyUniqueLen $ stCfg st - uniq = take uniqLen (BC.unpack (B.encode (hash (BC.pack (unwords (words lam)))))) - sbvToSV st (smtFunctionDef (atProxy (Proxy @f) nm <> "_" <> uniq) - (HasMeasure (MeasureEval (applyMeasure @(a -> SBV b) @r msr)) []) - hof arg) +smtHOFunctionWithMeasure nm f msr = smtHOFunctionGen nm f (HasMeasure (MeasureEval (applyMeasure @(a -> SBV b) @r msr)) []) - -- we get the functions as arrays here, so chase to find the result - resKindOf (KArray _ k) = resKindOf k - resKindOf k = k +-- | Common implementation for higher-order SMT function definitions. +smtHOFunctionGen :: forall a b f. + ( SMTDefinable (a -> SBV b) + , Lambda Symbolic f + , Lambda Symbolic (a -> SBV b) + , HasKind b + , HasKind f + , Typeable a + , Typeable b + , Typeable f + ) => String -- ^ prefix to use + -> f -- ^ The higher-order argument + -> Measure (a -> SBV b) -- ^ Termination measure + -> (a -> SBV b) -- ^ The ho-function we're modeling + -> a -> SBV b -- ^ The resulting function +smtHOFunctionGen nm f measure hof arg = SBV $ SVal (kindOf (Proxy @(SBV b))) $ Right $ cache r + where r st = do SMTLambda lam <- lambdaStr st HigherOrderArg (arrayResultKind (kindOf (Proxy @f))) f + let uniq = lambdaFingerprint st (T.unpack lam) + sbvToSV st (smtFunctionDef (atProxy (Proxy @f) nm <> "_" <> uniq) measure hof arg) + +-- | Chase through nested array kinds to find the final result kind. Higher-order +-- arguments are firstified into arrays, so we peel off the array wrappers. +arrayResultKind :: Kind -> Kind +arrayResultKind (KArray _ k) = arrayResultKind k +arrayResultKind k = k + +-- | Generate a short fingerprint from a lambda body string, used to give +-- unique names to firstified higher-order function instantiations. +lambdaFingerprint :: State -> String -> String +lambdaFingerprint st lam = take uniqLen (BC.unpack (B.encode (hash (BC.pack (unwords (words lam)))))) + where uniqLen = firstifyUniqueLen $ stCfg st {- HLint ignore module "Reduce duplication" -} {- HLint ignore module "Eta reduce" -} diff --git a/Data/SBV/Core/Operations.hs b/Data/SBV/Core/Operations.hs --- a/Data/SBV/Core/Operations.hs +++ b/Data/SBV/Core/Operations.hs @@ -932,8 +932,8 @@ -- merge, but simplify for certain boolean cases: case () of - () | swa == swb -> return swa -- if t then a else a ==> a - () | swa == trueSV && swb == falseSV -> return swt -- if t then true else false ==> t + () | swa == swb -> pure swa -- if t then a else a ==> a + () | swa == trueSV && swb == falseSV -> pure swt -- if t then true else false ==> t () | swa == falseSV && swb == trueSV -> newExpr st k (SBVApp Not [swt]) -- if t then false else true ==> not t () | swa == trueSV -> newExpr st k (SBVApp Or [swt, swb]) -- if t then true else b ==> t OR b () | swa == falseSV -> do swt' <- newExpr st KBool (SBVApp Not [swt]) @@ -969,7 +969,7 @@ r st = do sws <- mapM (svToSV st) xs swe <- svToSV st err if all (== swe) sws -- off-chance that all elts are the same - then return swe + then pure swe else do idx <- getTableIndex st kInd kElt sws swi <- svToSV st ind let len = length xs @@ -1141,7 +1141,7 @@ | True = Shr adjustedShift <- if kx == ki - then return sw2 + then pure sw2 else newExpr st kx (SBVApp (KindCast ki kx) [sw2]) newExpr st kx (SBVApp op [sw1, adjustedShift]) @@ -1369,14 +1369,14 @@ -- | Create a symbolic two argument operation; with shortcut optimizations mkSymOpSC :: (SV -> SV -> Maybe SV) -> Op -> State -> Kind -> SV -> SV -> IO SV -mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) return (shortCut a b) +mkSymOpSC shortCut op st k a b = maybe (newExpr st k (SBVApp op [a, b])) pure (shortCut a b) -- | Create a symbolic two argument operation; no shortcut optimizations mkSymOp :: Op -> State -> Kind -> SV -> SV -> IO SV mkSymOp = mkSymOpSC (const (const Nothing)) mkSymOp1SC :: (SV -> Maybe SV) -> Op -> State -> Kind -> SV -> IO SV -mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) return (shortCut a) +mkSymOp1SC shortCut op st k a = maybe (newExpr st k (SBVApp op [a])) pure (shortCut a) mkSymOp1 :: Op -> State -> Kind -> SV -> IO SV mkSymOp1 = mkSymOp1SC (const Nothing) @@ -1530,8 +1530,8 @@ newExpr st w32 (SBVApp (IEEEFP (FP_Reinterpret KFloat w32)) [f]) else do n <- newInternalVariable st w32 ysw <- newExpr st KFloat (SBVApp (IEEEFP (FP_Reinterpret w32 KFloat)) [n]) - internalConstraint st False [] $ fVal `svStrongEqual` SVal KFloat (Right (cache (\_ -> return ysw))) - return n + internalConstraint st False [] $ fVal `svStrongEqual` SVal KFloat (Right (cache (\_ -> pure ysw))) + pure n svFloatAsSWord32 (SVal k _) = error $ "svFloatAsSWord32: non-float type: " ++ show k -- | Convert an 'Data.SBV.SDouble' to an 'Data.SBV.SWord64', preserving the bit-correspondence. Note that since the @@ -1556,8 +1556,8 @@ newExpr st w64 (SBVApp (IEEEFP (FP_Reinterpret KDouble w64)) [f]) else do n <- newInternalVariable st w64 ysw <- newExpr st KDouble (SBVApp (IEEEFP (FP_Reinterpret w64 KDouble)) [n]) - internalConstraint st False [] $ fVal `svStrongEqual` SVal KDouble (Right (cache (\_ -> return ysw))) - return n + internalConstraint st False [] $ fVal `svStrongEqual` SVal KDouble (Right (cache (\_ -> pure ysw))) + pure n svDoubleAsSWord64 (SVal k _) = error $ "svDoubleAsSWord64: non-float type: " ++ show k -- | Convert a float to the word containing the corresponding bit pattern @@ -1575,8 +1575,8 @@ newExpr st kTo (SBVApp (IEEEFP (FP_Reinterpret kFrom kTo)) [f]) else do n <- newInternalVariable st kTo ysw <- newExpr st kFrom (SBVApp (IEEEFP (FP_Reinterpret kTo kFrom)) [n]) - internalConstraint st False [] $ fVal `svStrongEqual` SVal kFrom (Right (cache (\_ -> return ysw))) - return n + internalConstraint st False [] $ fVal `svStrongEqual` SVal kFrom (Right (cache (\_ -> pure ysw))) + pure n svFloatingPointAsSWord (SVal k _) = error $ "svFloatingPointAsSWord: non-float type: " ++ show k {- HLint ignore svIte "Eta reduce" -} diff --git a/Data/SBV/Core/Sized.hs b/Data/SBV/Core/Sized.hs --- a/Data/SBV/Core/Sized.hs +++ b/Data/SBV/Core/Sized.hs @@ -217,7 +217,7 @@ -- | Quickcheck instance for WordN instance KnownNat n => Arbitrary (WordN n) where - arbitrary = (WordN . norm . abs) `fmap` arbitrary + arbitrary = WordN . norm . abs <$> arbitrary where sz = intOfProxy (Proxy @n) norm v | sz == 0 = 0 @@ -225,7 +225,7 @@ -- | Quickcheck instance for IntN instance KnownNat n => Arbitrary (IntN n) where - arbitrary = (IntN . norm) `fmap` arbitrary + arbitrary = IntN . norm <$> arbitrary where sz = intOfProxy (Proxy @n) norm v | sz == 0 = 0 diff --git a/Data/SBV/Core/Symbolic.hs b/Data/SBV/Core/Symbolic.hs --- a/Data/SBV/Core/Symbolic.hs +++ b/Data/SBV/Core/Symbolic.hs @@ -10,7 +10,6 @@ ----------------------------------------------------------------------------- {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveDataTypeable #-} @@ -23,29 +22,27 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Core.Symbolic ( NodeId(..) - , SV(..), swKind, trueSV, falseSV, contextOfSV + , SV(..), swKind, trueSV, falseSV , Op(..), PBOp(..), OvOp(..), FPOp(..), NROp(..), StrOp(..), RegExOp(..), SeqOp(..), SetOp(..), SpecialRelOp(..), ADTOp(..) , RegExp(..), regExpToSMTString, SMTLambda(..) - , Quantifier(..), needsExistentials, SBVContext(..), globalSBVContext, checkCompatibleContext, VarContext(..) - , SBVType(..), svUninterpreted, svUninterpretedNamedArgs, newUninterpreted, prefixNameToUnique + , Quantifier(..), needsExistentials, SBVContext(..), globalSBVContext, VarContext(..) + , SBVType(..), svUninterpreted, svUninterpretedNamedArgs, newUninterpreted , SVal(..) , svMkSymVar, sWordN, sWordN_, sIntN, sIntN_ , svToSV, svToSymSV, forceSVArg , SBVExpr(..), newExpr, isCodeGenMode, isSafetyCheckingIStage, isRunIStage, isSetupIStage , Cached, cache, uncache, modifyState, modifyIncState - , NamedSymVar(..), Name, UserInputs, Inputs(..), getSV, swNodeId, namedNodeId - , addInternInput, addUserInput + , NamedSymVar(..), Name, UserInputs, Inputs(..), getSV, swNodeId , getUserName', getUserName , lookupInput , getSValPathCondition, extendSValPathCondition , getTableIndex, sObserve @@ -53,12 +50,12 @@ , inSMTMode, SBVRunMode(..), IStage(..), Result(..), ResultInp(..), UICodeKind(..), UIName(..) , registerKind, registerLabel, recordObservable , addAssertion, addNewSMTOption, imposeConstraint, internalConstraint, newInternalVariable, lambdaVar, quantVar - , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension + , SMTLibPgm(..), SMTLibVersion(..), smtLibVersionExtension, smtLibPgmText , SolverCapabilities(..) , extractSymbolicSimulationState, CnstMap , OptimizeStyle(..), Objective(..), Penalty(..), objectiveName, addSValOptGoal , MonadQuery(..), QueryT(..), Query, QueryState(..), QueryContext(..) - , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), TPOptions(..), SMTEngine, isEmptyModel + , SMTScript(..), Solver(..), SMTSolver(..), SMTResult(..), SMTModel(..), SMTConfig(..), TPOptions(..), SMTEngine , validationRequested, outputSVal, ProgInfo(..), mustIgnoreVar, getRootState , LambdaInfo(..) ) where @@ -73,7 +70,7 @@ import Control.Monad.Trans.Maybe (MaybeT) import Control.Monad.Writer.Strict (MonadWriter) import Data.IORef (IORef, newIORef, readIORef) -import Data.List (intercalate, sortBy, isPrefixOf) +import Data.List (intercalate, isPrefixOf) import Data.Maybe (fromMaybe) import Data.String (IsString(fromString)) @@ -94,7 +91,7 @@ import qualified Data.Generics as G (Data(..)) import qualified Data.Generics.Uniplate.Data as G import qualified Data.IntMap.Strict as IMap (IntMap, empty, lookup, insertWith) -import qualified Data.Map.Strict as Map (Map, empty, toList, lookup, insert, size, notMember, keysSet) +import qualified Data.Map.Strict as Map (Map, empty, toList, lookup, insert, size, keysSet) import qualified Data.Set as Set (Set, empty, toList, insert, member, notMember) import qualified Data.Foldable as F (toList) import qualified Data.Sequence as S (Seq, empty, (|>), lookup, elemIndexL) @@ -108,16 +105,13 @@ import Data.SBV.Core.Concrete import Data.SBV.SMT.SMTLibNames import Data.SBV.Utils.TDiff (Timing) -import Data.SBV.Utils.Lib (stringToQFS, checkObservableName, barify) +import Data.SBV.Utils.Lib (stringToQFS, checkObservableName, barify, mapToSortedList, showText) import Data.SBV.Utils.Numeric (RoundingMode) import Data.Containers.ListUtils (nubOrd) import Data.SBV.Control.Types -#if MIN_VERSION_base(4,11,0) -import Control.Monad.Fail as Fail -#endif -- | Context identifier. 0 is reserved global context newtype SBVContext = SBVContext Int64 deriving (Eq, Ord, G.Data, Show) @@ -155,10 +149,6 @@ data SV = SV !Kind !NodeId deriving G.Data --- | Which context are we using this var at? -contextOfSV :: SV -> SBVContext -contextOfSV (SV _ (NodeId (c, _, _))) = c - -- | For equality, we merely use the lambda-level/node-id instance Eq SV where SV _ n1 == SV _ n2 = n1 == n2 @@ -192,7 +182,7 @@ -- to an uninterpreted function are evaluated before called; the semantics of uinterpreted -- functions is necessarily strict; deviating from Haskell's forceSVArg :: SV -> IO () -forceSVArg (SV k n) = k `seq` n `seq` return () +forceSVArg (SV k n) = k `seq` n `seq` pure () -- | Constant False as an t'SV'. Note that this value always occupies slot -2 and level 0. falseSV :: SV @@ -233,8 +223,8 @@ | SignExtend Int | LkUp (Int, Kind, Kind, Int) !SV !SV -- (table-index, arg-type, res-type, length of the table) index out-of-bounds-value | KindCast Kind Kind - | Uninterpreted String - | QuantifiedBool String -- When we generate a forall/exists (nested etc.) boolean value. NB. This used to be "QuantifiedBool [Op] String", keeping track of Ops. That turned out to cause memory leaks. So avoid that. + | Uninterpreted T.Text + | QuantifiedBool T.Text -- When we generate a forall/exists (nested etc.) boolean value. NB. This used to be "QuantifiedBool [Op] String", keeping track of Ops. That turned out to cause memory leaks. So avoid that. | SpecialRelOp Kind SpecialRelOp -- Generate the equality to the internal operation | Label String -- Essentially no-op; useful for code generation to emit comments. | IEEEFP FPOp -- Floating-point ops, categorized separately @@ -257,9 +247,9 @@ deriving (Eq, Ord, Generic, G.Data, NFData) -- | ADT operations -data ADTOp = ADTConstructor String Kind -- Construct an ADT. Kind is the kind of the resulting ADT - | ADTTester String Kind -- Check if top-level constructor matches. Kind is the kind of the argument - | ADTAccessor String Kind -- Extract a field from an ADT value. Kind is the kind of the argument +data ADTOp = ADTConstructor T.Text Kind -- Construct an ADT. Kind is the kind of the resulting ADT + | ADTTester T.Text Kind -- Check if top-level constructor matches. Kind is the kind of the argument + | ADTAccessor T.Text Kind -- Extract a field from an ADT value. Kind is the kind of the argument deriving (Eq, Ord, Generic, G.Data, NFData) -- | Special relations supported by z3 @@ -458,37 +448,37 @@ -- | Convert a reg-exp to a Haskell-like string instance Show RegExp where - show = regExpToString show + show = T.unpack . regExpToText (T.pack . show) -- | Convert a reg-exp to a SMT-lib acceptable representation -regExpToSMTString :: RegExp -> String -regExpToSMTString = regExpToString (\s -> '"' : stringToQFS s ++ "\"") +regExpToSMTString :: RegExp -> Text +regExpToSMTString = regExpToText (\s -> "\"" <> T.pack (stringToQFS s) <> "\"") --- | Convert a RegExp to a string, parameterized by how strings are converted -regExpToString :: (String -> String) -> RegExp -> String -regExpToString fs (Literal s) = "(str.to.re " ++ fs s ++ ")" -regExpToString _ All = "re.all" -regExpToString _ AllChar = "re.allchar" -regExpToString _ None = "re.nostr" -regExpToString fs (Range ch1 ch2) = "(re.range " ++ fs [ch1] ++ " " ++ fs [ch2] ++ ")" -regExpToString _ (Conc []) = show (1 :: Integer) -regExpToString fs (Conc [x]) = regExpToString fs x -regExpToString fs (Conc xs) = "(re.++ " ++ unwords (map (regExpToString fs) xs) ++ ")" -regExpToString fs (KStar r) = "(re.* " ++ regExpToString fs r ++ ")" -regExpToString fs (KPlus r) = "(re.+ " ++ regExpToString fs r ++ ")" -regExpToString fs (Opt r) = "(re.opt " ++ regExpToString fs r ++ ")" -regExpToString fs (Comp r) = "(re.comp " ++ regExpToString fs r ++ ")" -regExpToString fs (Diff r1 r2) = "(re.diff " ++ regExpToString fs r1 ++ " " ++ regExpToString fs r2 ++ ")" -regExpToString fs (Loop lo hi r) - | lo >= 0, hi >= lo = "((_ re.loop " ++ show lo ++ " " ++ show hi ++ ") " ++ regExpToString fs r ++ ")" +-- | Convert a RegExp to text, parameterized by how strings are converted +regExpToText :: (String -> Text) -> RegExp -> Text +regExpToText fs (Literal s) = "(str.to.re " <> fs s <> ")" +regExpToText _ All = "re.all" +regExpToText _ AllChar = "re.allchar" +regExpToText _ None = "re.nostr" +regExpToText fs (Range ch1 ch2) = "(re.range " <> fs [ch1] <> " " <> fs [ch2] <> ")" +regExpToText _ (Conc []) = "1" +regExpToText fs (Conc [x]) = regExpToText fs x +regExpToText fs (Conc xs) = "(re.++ " <> T.unwords (map (regExpToText fs) xs) <> ")" +regExpToText fs (KStar r) = "(re.* " <> regExpToText fs r <> ")" +regExpToText fs (KPlus r) = "(re.+ " <> regExpToText fs r <> ")" +regExpToText fs (Opt r) = "(re.opt " <> regExpToText fs r <> ")" +regExpToText fs (Comp r) = "(re.comp " <> regExpToText fs r <> ")" +regExpToText fs (Diff r1 r2) = "(re.diff " <> regExpToText fs r1 <> " " <> regExpToText fs r2 <> ")" +regExpToText fs (Loop lo hi r) + | lo >= 0, hi >= lo = "((_ re.loop " <> showText lo <> " " <> showText hi <> ") " <> regExpToText fs r <> ")" | True = error $ "Invalid regular-expression Loop with arguments: " ++ show (lo, hi) -regExpToString fs (Power n r) - | n >= 0 = regExpToString fs (Loop n n r) +regExpToText fs (Power n r) + | n >= 0 = regExpToText fs (Loop n n r) | True = error $ "Invalid regular-expression Power with arguments: " ++ show n -regExpToString fs (Inter r1 r2) = "(re.inter " ++ regExpToString fs r1 ++ " " ++ regExpToString fs r2 ++ ")" -regExpToString _ (Union []) = "re.nostr" -regExpToString fs (Union [x]) = regExpToString fs x -regExpToString fs (Union xs) = "(re.union " ++ unwords (map (regExpToString fs) xs) ++ ")" +regExpToText fs (Inter r1 r2) = "(re.inter " <> regExpToText fs r1 <> " " <> regExpToText fs r2 <> ")" +regExpToText _ (Union []) = "re.nostr" +regExpToText fs (Union [x]) = regExpToText fs x +regExpToText fs (Union xs) = "(re.union " <> T.unwords (map (regExpToText fs) xs) <> ")" -- | Show instance for @StrOp@. Note that the mapping here is important to match the SMTLib equivalents. instance Show StrOp where @@ -497,22 +487,22 @@ show StrToCode = "str.to_code" show StrFromCode = "str.from_code" -- Note the breakage here with respect to argument order. We fix this explicitly later. - show (StrInRe s) = "str.in_re " ++ regExpToSMTString s + show (StrInRe s) = "str.in_re " ++ T.unpack (regExpToSMTString s) -- | Show instance for @RegExOp@. instance Show RegExOp where - show (RegExEq r1 r2) = "(= " ++ regExpToSMTString r1 ++ " " ++ regExpToSMTString r2 ++ ")" - show (RegExNEq r1 r2) = "(distinct " ++ regExpToSMTString r1 ++ " " ++ regExpToSMTString r2 ++ ")" + show (RegExEq r1 r2) = "(= " ++ T.unpack (regExpToSMTString r1) ++ " " ++ T.unpack (regExpToSMTString r2) ++ ")" + show (RegExNEq r1 r2) = "(distinct " ++ T.unpack (regExpToSMTString r1) ++ " " ++ T.unpack (regExpToSMTString r2) ++ ")" -- | For now, we represent lambda functions in op with their SMTLib equivalent strings. -- This might change in the future. -newtype SMTLambda = SMTLambda String +newtype SMTLambda = SMTLambda T.Text deriving (Eq, Ord, G.Data, Generic) deriving newtype NFData -- | Simple show instance for SMTLambda instance Show SMTLambda where - show (SMTLambda s) = s + show (SMTLambda s) = T.unpack s -- | Sequence operations. Indexed by the element kind. data SeqOp = SeqLen Kind @@ -586,8 +576,8 @@ where tinfo = "table" ++ show ti ++ "(" ++ show at ++ " -> " ++ show rt ++ ", " ++ show l ++ ")" show (KindCast fr to) = "cast_" ++ show fr ++ "_" ++ show to - show (Uninterpreted i) = "[uninterpreted] " ++ i - show (QuantifiedBool i) = "[quantified boolean] " ++ i + show (Uninterpreted i) = "[uninterpreted] " ++ T.unpack i + show (QuantifiedBool i) = "[quantified boolean] " ++ T.unpack i show (Label s) = "[label] " ++ s @@ -706,18 +696,10 @@ instance Ord NamedSymVar where compare (NamedSymVar l _) (NamedSymVar r _) = compare l r --- | Convert to a named symvar, from string -toNamedSV' :: SV -> String -> NamedSymVar -toNamedSV' s = NamedSymVar s . T.pack - -- | Convert to a named symvar, from text toNamedSV :: SV -> Name -> NamedSymVar toNamedSV = NamedSymVar --- | Get the node id from a named sym var -namedNodeId :: NamedSymVar -> NodeId -namedNodeId = swNodeId . getSV - -- | Get the SV from a named sym var getSV :: NamedSymVar -> SV getSV (NamedSymVar s _) = s @@ -761,8 +743,8 @@ objectiveName (AssertWithPenalty s _ _) = s -- | The state we keep track of as we interact with the solver -data QueryState = QueryState { queryAsk :: Maybe Int -> String -> IO String - , querySend :: Maybe Int -> String -> IO () +data QueryState = QueryState { queryAsk :: Maybe Int -> Text -> IO String + , querySend :: Maybe Int -> Text -> IO () , queryRetrieveResponse :: Maybe Int -> IO String , queryConfig :: SMTConfig , queryTerminate :: Maybe C.SomeException -> IO () @@ -910,10 +892,10 @@ shcg (s, ss) = ("Variable: " ++ s) : map (" " ++) ss - shn (NamedSymVar sv nm) = " " <> ni <> " :: " ++ show (swKind sv) ++ alias + shn (NamedSymVar sv nm) = " " ++ ni ++ " :: " ++ show (swKind sv) ++ alias where ni = show sv - alias | ni == T.unpack nm = "" + alias | T.pack ni == nm = "" | True = ", aliasing " ++ show nm shq (q, v) = shn v ++ ", " ++ if q == ALL then "universal" else "existential" @@ -928,11 +910,7 @@ soft False = "" shAssert (nm, stk, p) = " -- assertion: " ++ nm ++ " " ++ maybe "[No location]" -#if MIN_VERSION_base(4,9,0) prettyCallStack -#else - showCallStack -#endif stk ++ ": " ++ show p -- | Expression map, used for hash-consing @@ -1005,11 +983,11 @@ -- | Is this a CodeGen run? (i.e., generating code) isCodeGenMode :: State -> IO Bool isCodeGenMode State{runMode} = do rm <- readIORef runMode - return $ case rm of - Concrete{} -> False - SMTMode{} -> False - LambdaGen{} -> False - CodeGen -> True + pure $ case rm of + Concrete{} -> False + SMTMode{} -> False + LambdaGen{} -> False + CodeGen -> True -- | The state in query mode, i.e., additional context data IncState = IncState { rNewInps :: IORef [NamedSymVar] -- always existential! @@ -1031,14 +1009,14 @@ ui <- newIORef Map.empty pgm <- newIORef (SBVPgm S.empty) cstrs <- newIORef S.empty - return IncState { rNewInps = is - , rNewKinds = ks - , rNewConsts = nc - , rNewTbls = tm - , rNewUIs = ui - , rNewAsgns = pgm - , rNewConstraints = cstrs - } + pure IncState { rNewInps = is + , rNewKinds = ks + , rNewConsts = nc + , rNewTbls = tm + , rNewUIs = ui + , rNewAsgns = pgm + , rNewConstraints = cstrs + } -- | Get a new IncState withNewIncState :: State -> (State -> IO a) -> IO (IncState, a) @@ -1047,7 +1025,7 @@ R.modifyIORef' (rIncState st) (const is) r <- cont st finalIncState <- readIORef (rIncState st) - return (finalIncState, r) + pure (finalIncState, r) -- | User defined inputs type UserInputs = S.Seq NamedSymVar @@ -1112,7 +1090,7 @@ | True = Nothing -- l != Just 0, a lambda var, whether top-level or in a scope, so we ignore where (_, l, i) = getId (swNodeId sv) - svs = fmap f ns + svs = f <$> ns res = case S.lookup i ns of -- Nothing on negative Int or Int > length seq Nothing -> secondLookup x@(Just e) -> if sv == f e then x else secondLookup @@ -1123,8 +1101,8 @@ -- | A defined function/value data SMTDef = SMTDef Kind -- ^ Final kind of the definition (resulting kind, not the params) [String] -- ^ other definitions it refers to - (Maybe String) -- ^ parameter string - (Int -> String) -- ^ Body, in SMTLib syntax, given the tab amount + (Maybe Text) -- ^ parameter string + (Int -> Text) -- ^ Body, in SMTLib syntax, given the tab amount deriving G.Data -- | For debug purposes @@ -1132,9 +1110,9 @@ show (SMTDef fk frees p body) = unlines [ "-- User defined function:" , "-- Final return type : " ++ show fk , "-- Refers to : " ++ intercalate ", " frees - , "-- Parameters : " ++ fromMaybe "NONE" p + , "-- Parameters : " ++ maybe "NONE" T.unpack p , "-- Body : " - , body 2 + , T.unpack (body 2) ] -- | NFData instance for SMTDef @@ -1142,7 +1120,7 @@ rnf (SMTDef fk frees params body) = rnf fk `seq` rnf frees `seq` rnf params `seq` rnf body -- | Compare two SMTDef values for semantic equality. --- The body is @(Int -> String)@ where @Int@ is indentation; we compare rendered output at indent 0. +-- The body is @(Int -> Text)@ where @Int@ is indentation; we compare rendered output at indent 0. smtDefEq :: SMTDef -> SMTDef -> Bool smtDefEq (SMTDef k1 refs1 params1 body1) (SMTDef k2 refs2 params2 body2) = k1 == k2 && refs1 == refs2 && params1 == params2 && body1 0 == body2 0 @@ -1228,11 +1206,11 @@ -- | Are we running in proof mode? inSMTMode :: State -> IO Bool inSMTMode State{runMode} = do rm <- readIORef runMode - return $ case rm of - CodeGen -> False - LambdaGen{} -> False - Concrete{} -> False - SMTMode{} -> True + pure $ case rm of + CodeGen -> False + LambdaGen{} -> False + Concrete{} -> False + SMTMode{} -> True -- | The "Symbolic" value. Either a constant (@Left@) or a symbolic -- value (@Right Cached@). Note that caching is essential for making @@ -1275,7 +1253,7 @@ rm <- readIORef runMode case rm of SMTMode _ IRun _ _ -> interactiveUpdate - _ -> return () + _ -> pure () -- | Modify the incremental state modifyIncState :: State -> (IncState -> IORef a) -> (a -> a) -> IO () @@ -1284,21 +1262,21 @@ R.modifyIORef' (field incState) update -- | Add an observable -recordObservable :: State -> String -> (CV -> Bool) -> SV -> IO () -recordObservable st (T.pack -> nm) chk sv = modifyState st rObservables (S.|> (nm, chk, sv)) (return ()) +recordObservable :: State -> Text -> (CV -> Bool) -> SV -> IO () +recordObservable st nm chk sv = modifyState st rObservables (S.|> (nm, chk, sv)) (pure ()) -- | Increment the variable counter incrementInternalCounter :: State -> IO Int incrementInternalCounter st = do ctr <- readIORef (rctr st) - modifyState st rctr (+1) (return ()) - return ctr + modifyState st rctr (+1) (pure ()) + pure ctr {-# INLINE incrementInternalCounter #-} -- | Increment the fresh-var counter incrementFreshNameCounter :: State -> IO Int incrementFreshNameCounter st = do ctr <- readIORef (freshNameCtr st) - modifyState st freshNameCtr (+1) (return ()) - return ctr + modifyState st freshNameCtr (+1) (pure ()) + pure ctr {-# INLINE incrementFreshNameCounter #-} -- | Kind of code we have for uninterpretation @@ -1331,18 +1309,6 @@ mapM_ forceSVArg sws newExpr st k $ SBVApp op sws --- | Generate a unique name for the given function based on the object's stable name -prefixNameToUnique :: State -> String -> IO String -prefixNameToUnique st pre = do - uiMap <- readIORef (rUIMap st) - - let suffix 0 = pre - suffix i = pre ++ "_" ++ show i - - case [cand | i <- [0::Int ..], let cand = suffix i, cand `Map.notMember` uiMap] of - (n:_) -> pure n - [] -> error $ "genUniqueName: Can't generate a unique name for prefix: " ++ pre -- can't happen - -- | Create a new value, possibly with user given code. This function might change -- the name given, putting bars around it if needed. That's the name returned. newUninterpreted :: State -> UIName -> Maybe [String] -> SBVType -> UICodeKind -> IO Op @@ -1351,9 +1317,9 @@ let (adtOp, candName) = case uiName of UIGiven n -> (False, n) UIADT o -> case o of - ADTConstructor n _ -> (True, n) - ADTTester n _ -> (True, n) - ADTAccessor n _ -> (True, n) + ADTConstructor n _ -> (True, T.unpack n) + ADTTester n _ -> (True, T.unpack n) + ADTAccessor n _ -> (True, T.unpack n) -- determine the final name. We leave constructors alone. let nm = case () of @@ -1392,7 +1358,7 @@ ] pure True UICgC c -> -- No need to record the code in interactive mode: CodeGen doesn't use interactive - do modifyState st rCgMap (Map.insert nm c) (return ()) + do modifyState st rCgMap (Map.insert nm c) (pure ()) pure True let checkType :: SBVType -> r -> r @@ -1406,18 +1372,19 @@ unless adtOp $ do uiMap <- readIORef (rUIMap st) case nm `Map.lookup` uiMap of - Just (_, _, t') -> checkType t' (return ()) + Just (_, _, t') -> checkType t' (pure ()) Nothing -> modifyState st rUIMap (Map.insert nm (isCurried, mbArgNames, t)) $ modifyIncState st rNewUIs (\newUIs -> case nm `Map.lookup` newUIs of Just (_, _, t') -> checkType t' newUIs Nothing -> Map.insert nm (isCurried, mbArgNames, t) newUIs) - pure $ case uiName of - UIGiven{} -> Uninterpreted nm - UIADT (ADTConstructor _ k) -> ADTOp (ADTConstructor nm k) - UIADT (ADTTester _ k) -> ADTOp (ADTTester nm k) - UIADT (ADTAccessor _ k) -> ADTOp (ADTAccessor nm k) + pure $ let tnm = T.pack nm + in case uiName of + UIGiven{} -> Uninterpreted tnm + UIADT (ADTConstructor _ k) -> ADTOp (ADTConstructor tnm k) + UIADT (ADTTester _ k) -> ADTOp (ADTTester tnm k) + UIADT (ADTAccessor _ k) -> ADTOp (ADTAccessor tnm k) -- | Add a new sAssert based constraint addAssertion :: State -> Maybe CallStack -> String -> SV -> IO () @@ -1435,14 +1402,14 @@ let n = "__internal_sbv_" <> nm v = NamedSymVar sv n modifyState st rinps (addUserInput sv n) $ modifyIncState st rNewInps (v :) - return sv + pure sv {-# INLINE newInternalVariable #-} -- | Create a variable to be used in a constraint-expression quantVar :: Quantifier -> State -> Kind -> IO SV quantVar q st k = do v@(NamedSymVar sv _) <- newSV st k - modifyState st rlambdaInps (S.|> (q, v)) (return ()) - return sv + modifyState st rlambdaInps (S.|> (q, v)) (pure ()) + pure sv {-# INLINE quantVar #-} -- | Create a variable to be used in a lambda-expression @@ -1456,7 +1423,7 @@ ll <- readIORef (rLambdaLevel st) let sv = SV k (NodeId (sbvContext st, ll, ctr)) registerKind st k - return $ NamedSymVar sv $ T.pack (show sv) + pure $ NamedSymVar sv $ showText sv {-# INLINE newSV #-} -- | Register a new kind with the system, used for uninterpreted sorts. @@ -1503,17 +1470,17 @@ -- Don't forget to register subkinds! case k of - KVar {} -> return () - KBool {} -> return () - KBounded {} -> return () - KUnbounded{} -> return () - KReal {} -> return () - KFloat {} -> return () - KDouble {} -> return () - KFP {} -> return () - KRational {} -> return () - KChar {} -> return () - KString {} -> return () + KVar {} -> pure () + KBool {} -> pure () + KBounded {} -> pure () + KUnbounded{} -> pure () + KReal {} -> pure () + KFloat {} -> pure () + KDouble {} -> pure () + KFP {} -> pure () + KRational {} -> pure () + KChar {} -> pure () + KString {} -> pure () KApp _ ks -> mapM_ (registerKind st) ks KADT _ pks cks -> mapM_ (registerKind st) (map snd pks ++ concatMap snd cks) @@ -1535,7 +1502,7 @@ = do old <- readIORef $ rUsedLbls st if nm `Set.member` old then err "is used multiple times. Please do not use duplicate names!" - else modifyState st rUsedLbls (Set.insert nm) (return ()) + else modifyState st rUsedLbls (Set.insert nm) (pure ()) where err w = error $ "SBV (" ++ whence ++ "): " ++ show nm ++ " " ++ w @@ -1547,11 +1514,11 @@ -- NB. Unlike in 'newExpr', we don't have to make sure the returned sv -- has the kind we asked for, because the constMap stores the full CV -- which already has a kind field in it. - Just sv -> return sv + Just sv -> pure sv Nothing -> do (NamedSymVar sv _) <- newSV st (kindOf c) let ins = Map.insert c sv modifyState st rconstMap ins $ modifyIncState st rNewConsts ins - return sv + pure sv {-# INLINE newConst #-} -- | Create a new table; hash-cons as necessary @@ -1560,11 +1527,11 @@ let key = (at, rt, elts) tblMap <- readIORef (rtblMap st) case key `Map.lookup` tblMap of - Just i -> return i + Just i -> pure i _ -> do let i = Map.size tblMap upd = Map.insert key i modifyState st rtblMap upd $ modifyIncState st rNewTbls upd - return i + pure i -- | Create a new expression; hash-cons as necessary newExpr :: State -> Kind -> SBVExpr -> IO SV @@ -1577,13 +1544,13 @@ -- at first, but `svSign` and `svUnsign` rely on this as we can -- get the same expression but at a different type. See -- as an example. - Just sv | kindOf sv == k -> return sv + Just sv | kindOf sv == k -> pure sv _ -> do (NamedSymVar sv _) <- newSV st k checkConsistent sv e let append (SBVPgm xs) = SBVPgm (xs S.|> (sv, e)) modifyState st spgm append $ modifyIncState st rNewAsgns append - modifyState st rexprMap (Map.insert e sv) (return ()) - return sv + modifyState st rexprMap (Map.insert e sv) (pure ()) + pure sv {-# INLINE newExpr #-} -- | In rare cases, we can get a context mismatch; so make sure the expression is well-formed. @@ -1603,15 +1570,6 @@ compatibleContext c1 c2 = c1 == c2 || c1 == globalSBVContext || c2 == globalSBVContext {-# INLINE compatibleContext #-} --- | Same as checkConsistent above, except in an array context -checkCompatibleContext :: SBVContext -> SBVContext -> IO () -checkCompatibleContext ctx1 ctx2 - | ctx1 `compatibleContext` ctx2 - = pure () - | True - = contextMismatchError ctx1 ctx2 -{-# INLINE checkCompatibleContext #-} - -- | Convert a symbolic value to an internal SV svToSV :: State -> SVal -> IO SV svToSV st (SVal _ (Left c)) = newConst st c @@ -1648,9 +1606,7 @@ newtype SymbolicT m a = SymbolicT { runSymbolicT :: ReaderT State m a } deriving newtype ( Applicative, Functor, Monad, MonadIO, MonadTrans , MonadError e, MonadState s, MonadWriter w -#if MIN_VERSION_base(4,11,0) - , Fail.MonadFail -#endif + , MonadFail ) -- | `MonadSymbolic` instance for `SymbolicT m` @@ -1726,11 +1682,11 @@ QueryVar -> (True, Just EX) mkS q = do (NamedSymVar sv internalName) <- newSV st k - let nm = fromMaybe (T.unpack internalName) mbNm + let nm = maybe internalName T.pack mbNm introduceUserName st (isQueryVar, isTracker) nm k q sv - mkC cv = do modifyState st rCInfo ((fromMaybe "_" mbNm, cv):) (return ()) - return $ SVal k (Left cv) + mkC cv = do modifyState st rCInfo ((fromMaybe "_" mbNm, cv):) (pure ()) + pure $ SVal k (Left cv) case (mbQ, rm) of (Just q, SMTMode{} ) -> mkS q @@ -1759,8 +1715,8 @@ (NamedSymVar sv internalName) <- newSV st k - let nm = fromMaybe (T.unpack internalName) mbNm - nsv = toNamedSV' sv nm + let nm = maybe internalName T.pack mbNm + nsv = NamedSymVar sv nm -- Ignore the context equivalence check here. When validating, we are in a different -- context; so they won't match @@ -1783,11 +1739,11 @@ mkC cv -- | Introduce a new user name. We simply append a suffix if we have seen this variable before. -introduceUserName :: State -> (Bool, Bool) -> String -> Kind -> Quantifier -> SV -> IO SVal +introduceUserName :: State -> (Bool, Bool) -> Text -> Kind -> Quantifier -> SV -> IO SVal introduceUserName st@State{runMode} (isQueryVar, isTracker) nmOrig k q sv = do old <- allInputs <$> readIORef (rinps st) - let nm = mkUnique (T.pack nmOrig) old + let nm = mkUnique nmOrig old -- If this is not a query variable and we're in a query, reject it. -- See https://github.com/LeventErkok/sbv/issues/554 for the rationale. @@ -1819,13 +1775,13 @@ $ noInteractive ["Adding a new tracker variable in interactive mode: " ++ show nm] else modifyState st rinps (addUserInput sv nm) $ modifyIncState st rNewInps newInp - return $ SVal k $ Right $ cache (const (return sv)) + pure $ SVal k $ Right $ cache (const (pure sv)) where -- The following can be rather slow if we keep reusing the same prefix, but I doubt it'll be a problem in practice -- Also, the following will fail if we span the range of integers without finding a match, but your computer would -- die way ahead of that happening if that's the case! mkUnique :: T.Text -> Set.Set Name -> T.Text - mkUnique prefix names = case dropWhile (`Set.member` names) (prefix : [prefix <> "_" <> T.pack (show i) | i <- [(0::Int)..]]) of + mkUnique prefix names = case dropWhile (`Set.member` names) (prefix : [prefix <> "_" <> showText i | i <- [(0::Int)..]]) of h:_ -> h _ -> error $ "mkUnique: Impossible happened! Couldn't get a unique name for " ++ show (prefix, names) @@ -1951,7 +1907,7 @@ mapM_ check $ nubOrd $ G.universeBi res - return (r, res) + pure (r, res) -- | Grab the program from a running symbolic simulation state. extractSymbolicSimulationState :: State -> IO Result @@ -1995,14 +1951,12 @@ outsO <- reverse <$> readIORef outs - let swap (a, b) = (b, a) - cmp (a, _) (b, _) = a `compare` b - arrange (i, (at, rt, es)) = ((i, at, rt), es) + let arrange (i, (at, rt, es)) = ((i, at, rt), es) constMap <- readIORef (rconstMap st) - let cnsts = sortBy cmp . map swap . Map.toList $ constMap + let cnsts = mapToSortedList constMap - tbls <- map arrange . sortBy cmp . map swap . Map.toList <$> readIORef tables + tbls <- map arrange . mapToSortedList <$> readIORef tables defnMap <- readIORef defns let ds = Map.toList defnMap definedSet = Map.keysSet defnMap @@ -2019,12 +1973,12 @@ pinfo <- readIORef progInfo - return $ Result pinfo knds traceVals observables cgMap inpsO (constMap, cnsts) tbls unint ds (SBVPgm rpgm) extraCstrs assertions outsO + pure $ Result pinfo knds traceVals observables cgMap inpsO (constMap, cnsts) tbls unint ds (SBVPgm rpgm) extraCstrs assertions outsO -- | Generalization of 'Data.SBV.addNewSMTOption' addNewSMTOption :: MonadSymbolic m => SMTOption -> m () addNewSMTOption o = do st <- symbolicEnv - liftIO $ modifyState st rSMTOptions (o:) (return ()) + liftIO $ modifyState st rSMTOptions (o:) (pure ()) -- | Generalization of 'Data.SBV.imposeConstraint' imposeConstraint :: MonadSymbolic m => Bool -> [(String, String)] -> SVal -> m () @@ -2068,7 +2022,7 @@ let mkGoal nm orig = liftIO $ do origSV <- svToSV st orig track <- svMkTrackerVar (kindOf orig) nm st trackSV <- svToSV st track - return (origSV, trackSV) + pure (origSV, trackSV) let walk (Minimize nm v) = Minimize nm <$> mkGoal nm v walk (Maximize nm v) = Maximize nm <$> mkGoal nm v @@ -2088,18 +2042,18 @@ | True = do st <- symbolicEnv liftIO $ do xsv <- svToSV st x - recordObservable st m (const True) xsv + recordObservable st (T.pack m) (const True) xsv -- | Generalization of 'Data.SBV.outputSVal' outputSVal :: MonadSymbolic m => SVal -> m () outputSVal (SVal _ (Left c)) = do st <- symbolicEnv sv <- liftIO $ newConst st c - liftIO $ modifyState st routs (sv:) (return ()) + liftIO $ modifyState st routs (sv:) (pure ()) outputSVal (SVal _ (Right f)) = do st <- symbolicEnv sv <- liftIO $ uncache f st - liftIO $ modifyState st routs (sv:) (return ()) + liftIO $ modifyState st routs (sv:) (pure ()) --------------------------------------------------------------------------------- -- * Cached values @@ -2135,10 +2089,10 @@ sn <- f `seq` makeStableName f let h = hashStableName sn case (h `IMap.lookup` stored) >>= (sn `lookup`) of - Just r -> return r + Just r -> pure r Nothing -> do r <- f st r `seq` R.modifyIORef' rCache (IMap.insertWith (++) h [(sn, r)]) - return r + pure r -- | Representation of SMTLib Program versions. As of June 2015, we're dropping support -- for SMTLib1, and supporting SMTLib2 only. We keep this data-type around in case @@ -2160,18 +2114,15 @@ instance Show SMTLibPgm where show (SMTLibPgm _ pgm _) = T.unpack pgm +-- | Extract the program text from an SMTLibPgm without converting to String. +smtLibPgmText :: SMTLibPgm -> Text +smtLibPgmText (SMTLibPgm _ pgm _) = pgm + -- Other Technicalities.. instance NFData GeneralizedCV where rnf (ExtendedCV e) = e `seq` () rnf (RegularCV c) = c `seq` () -#if MIN_VERSION_base(4,9,0) -#else --- Can't really force this, but not a big deal -instance NFData CallStack where - rnf _ = () -#endif - instance NFData NamedSymVar where rnf (NamedSymVar s n) = rnf s `seq` rnf n @@ -2266,7 +2217,7 @@ , dsatPrecision :: Maybe Double -- ^ Delta-sat precision , solver :: SMTSolver -- ^ The actual SMT solver. , extraArgs :: [String] -- ^ Extra command line arguments to pass to the solver. - , roundingMode :: RoundingMode -- ^ Rounding mode to use for floating-point conversions + , roundingMode :: RoundingMode -- ^ Rounding mode to use for floating-point calculations. Defaults to RNE. , solverSetOptions :: [SMTOption] -- ^ Options to set as we start the solver , ignoreExitCode :: Bool -- ^ If true, we shall ignore the exit code upon exit. Otherwise we require ExitSuccess. , redirectVerbose :: Maybe FilePath -- ^ Redirect the verbose output to this file if given. If Nothing, stdout is implied. @@ -2285,8 +2236,8 @@ } -- | Ignore internal names and those the user told us to -mustIgnoreVar :: SMTConfig -> String -> Bool -mustIgnoreVar cfg s = "__internal_sbv" `isPrefixOf` s || isNonModelVar cfg s +mustIgnoreVar :: SMTConfig -> T.Text -> Bool +mustIgnoreVar cfg s = "__internal_sbv" `T.isPrefixOf` s || isNonModelVar cfg (T.unpack s) -- | We show the name of the solver for the config. Arguably this is misleading, but better than nothing. instance Show SMTConfig where @@ -2312,10 +2263,6 @@ } deriving Show --- | Is it the case that the model is really uninteresting? This is the case when there are no assocs nor ui's -isEmptyModel :: SMTModel -> Bool -isEmptyModel SMTModel{modelAssocs, modelUIFuns} = null modelAssocs && null modelUIFuns - -- | The result of an SMT solver call. Each constructor is tagged with -- the t'SMTConfig' that created it so that further tools can inspect it -- and build layers of results, if needed. For ordinary uses of the library, @@ -2338,7 +2285,7 @@ type SMTEngine = forall res. SMTConfig -- ^ current configuration -> State -- ^ the state in which to run the engine - -> String -- ^ program + -> Text -- ^ program -> (State -> IO res) -- ^ continuation -> IO res @@ -2359,7 +2306,7 @@ data SMTSolver = SMTSolver { name :: Solver -- ^ The solver in use , executable :: String -- ^ The path to its executable - , preprocess :: String -> String -- ^ Each line sent to the solver will be passed through this function (typically id) + , preprocess :: Text -> Text -- ^ Each line sent to the solver will be passed through this function (typically id) , options :: SMTConfig -> [String] -- ^ Options to provide to the solver , engine :: SMTEngine -- ^ The solver engine, responsible for interpreting solver output , capabilities :: SolverCapabilities -- ^ Various capabilities of the solver diff --git a/Data/SBV/Dynamic.hs b/Data/SBV/Dynamic.hs --- a/Data/SBV/Dynamic.hs +++ b/Data/SBV/Dynamic.hs @@ -166,78 +166,78 @@ -- | Create SMT-Lib benchmark for a sat call generateSMTBenchmarkSat :: Symbolic SVal -> IO String -generateSMTBenchmarkSat s = SBV.generateSMTBenchmarkSat (fmap toSBool s) +generateSMTBenchmarkSat s = SBV.generateSMTBenchmarkSat (toSBool <$> s) -- | Create SMT-Lib benchmark for a proof call generateSMTBenchmarkProof :: Symbolic SVal -> IO String -generateSMTBenchmarkProof s = SBV.generateSMTBenchmarkProof (fmap toSBool s) +generateSMTBenchmarkProof s = SBV.generateSMTBenchmarkProof (toSBool <$> s) -- | Proves the predicate using the given SMT-solver proveWith :: SMTConfig -> Symbolic SVal -> IO ThmResult -proveWith cfg s = SBV.proveWith cfg (fmap toSBool s) +proveWith cfg s = SBV.proveWith cfg (toSBool <$> s) -- | Find a satisfying assignment using the given SMT-solver satWith :: SMTConfig -> Symbolic SVal -> IO SatResult -satWith cfg s = SBV.satWith cfg (fmap toSBool s) +satWith cfg s = SBV.satWith cfg (toSBool <$> s) -- | Check safety using the given SMT-solver safeWith :: SMTConfig -> Symbolic SVal -> IO [SafeResult] -safeWith cfg s = SBV.safeWith cfg (fmap toSBool s) +safeWith cfg s = SBV.safeWith cfg (toSBool <$> s) -- | Find all satisfying assignments using the given SMT-solver allSatWith :: SMTConfig -> Symbolic SVal -> IO AllSatResult -allSatWith cfg s = SBV.allSatWith cfg (fmap toSBool s) +allSatWith cfg s = SBV.allSatWith cfg (toSBool <$> s) -- | Prove a property with multiple solvers, running them in separate threads. The -- results will be returned in the order produced. proveWithAll :: [SMTConfig] -> Symbolic SVal -> IO [(Solver, NominalDiffTime, ThmResult)] -proveWithAll cfgs s = SBV.proveWithAll cfgs (fmap toSBool s) +proveWithAll cfgs s = SBV.proveWithAll cfgs (toSBool <$> s) -- | Prove a property with multiple solvers, running them in separate -- threads. Only the result of the first one to finish will be -- returned, remaining threads will be killed. proveWithAny :: [SMTConfig] -> Symbolic SVal -> IO (Solver, NominalDiffTime, ThmResult) -proveWithAny cfgs s = SBV.proveWithAny cfgs (fmap toSBool s) +proveWithAny cfgs s = SBV.proveWithAny cfgs (toSBool <$> s) -- | Prove a property with query mode using multiple threads. Each query -- computation will spawn a thread and a unique instance of your solver to run -- asynchronously. The 'Symbolic' t'SVal' is duplicated for each thread. This -- function will block until all child threads return. proveConcurrentWithAll :: SMTConfig -> Symbolic SVal -> [Query SVal] -> IO [(Solver, NominalDiffTime, ThmResult)] -proveConcurrentWithAll cfg s queries = SBV.proveConcurrentWithAll cfg queries (fmap toSBool s) +proveConcurrentWithAll cfg s queries = SBV.proveConcurrentWithAll cfg queries (toSBool <$> s) -- | Prove a property with query mode using multiple threads. Each query -- computation will spawn a thread and a unique instance of your solver to run -- asynchronously. The 'Symbolic' t'SVal' is duplicated for each thread. This -- function will return the first query computation that completes, killing the others. proveConcurrentWithAny :: SMTConfig -> Symbolic SVal -> [Query SVal] -> IO (Solver, NominalDiffTime, ThmResult) -proveConcurrentWithAny cfg s queries = SBV.proveConcurrentWithAny cfg queries (fmap toSBool s) +proveConcurrentWithAny cfg s queries = SBV.proveConcurrentWithAny cfg queries (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple solvers, -- running them in separate threads. The results will be returned in -- the order produced. satWithAll :: [SMTConfig] -> Symbolic SVal -> IO [(Solver, NominalDiffTime, SatResult)] -satWithAll cfgs s = SBV.satWithAll cfgs (fmap toSBool s) +satWithAll cfgs s = SBV.satWithAll cfgs (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple solvers, -- running them in separate threads. Only the result of the first one -- to finish will be returned, remaining threads will be killed. satWithAny :: [SMTConfig] -> Symbolic SVal -> IO (Solver, NominalDiffTime, SatResult) -satWithAny cfgs s = SBV.satWithAny cfgs (fmap toSBool s) +satWithAny cfgs s = SBV.satWithAny cfgs (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple threads in query -- mode. The 'Symbolic' t'SVal' represents what is known to all child query threads. -- Each query thread will spawn a unique instance of the solver. Only the first -- one to finish will be returned and the other threads will be killed. satConcurrentWithAny :: SMTConfig -> [Query b] -> Symbolic SVal -> IO (Solver, NominalDiffTime, SatResult) -satConcurrentWithAny cfg qs s = SBV.satConcurrentWithAny cfg qs (fmap toSBool s) +satConcurrentWithAny cfg qs s = SBV.satConcurrentWithAny cfg qs (toSBool <$> s) -- | Find a satisfying assignment to a property with multiple threads in query -- mode. The 'Symbolic' t'SVal' represents what is known to all child query threads. -- Each query thread will spawn a unique instance of the solver. This function -- will block until all child threads have completed. satConcurrentWithAll :: SMTConfig -> [Query b] -> Symbolic SVal -> IO [(Solver, NominalDiffTime, SatResult)] -satConcurrentWithAll cfg qs s = SBV.satConcurrentWithAll cfg qs (fmap toSBool s) +satConcurrentWithAll cfg qs s = SBV.satConcurrentWithAll cfg qs (toSBool <$> s) -- | Extract a model, the result is a tuple where the first argument (if True) -- indicates whether the model was "probable". (i.e., if the solver returned unknown.) diff --git a/Data/SBV/Either.hs b/Data/SBV/Either.hs --- a/Data/SBV/Either.hs +++ b/Data/SBV/Either.hs @@ -18,7 +18,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Either ( -- * Constructing sums diff --git a/Data/SBV/Internals.hs b/Data/SBV/Internals.hs --- a/Data/SBV/Internals.hs +++ b/Data/SBV/Internals.hs @@ -19,7 +19,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -103,6 +103,7 @@ import GHC.TypeLits import qualified Data.SBV.Control.Utils as Query +import qualified Data.Text as T import Data.SBV.Lambda @@ -118,7 +119,7 @@ -- Note that this is inherently dangerous as it can put the solver in an arbitrary -- state and confuse SBV. If you use this feature, you are on your own! sendStringToSolver :: (MonadIO m, MonadQuery m) => String -> m () -sendStringToSolver = Query.send False +sendStringToSolver = Query.send False . T.pack -- | Retrieve multiple responses from the solver, until it responds with a user given -- tag that we shall arrange for internally. The optional timeout is in milliseconds. @@ -132,7 +133,7 @@ -- Note that this is inherently dangerous as it can put the solver in an arbitrary -- state and confuse SBV. sendRequestToSolver :: (MonadIO m, MonadQuery m) => String -> m String -sendRequestToSolver = Query.ask +sendRequestToSolver = Query.ask . T.pack {- $coordinateSolverInfo In rare cases it might be necessary to send an arbitrary string down to the solver. Needless to say, this diff --git a/Data/SBV/Lambda.hs b/Data/SBV/Lambda.hs --- a/Data/SBV/Lambda.hs +++ b/Data/SBV/Lambda.hs @@ -13,10 +13,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Lambda ( lambda, lambdaStr @@ -33,6 +34,7 @@ import Data.SBV.Core.Data import Data.SBV.Core.Kind import Data.SBV.SMT.SMTLib2 +import Data.SBV.Utils.Lib (showText) import Data.SBV.Utils.PrettyNum import Data.SBV.Core.Symbolic hiding (mkNewState) @@ -56,8 +58,8 @@ data Defn = Defn [String] -- The uninterpreted names referred to in the body [String] -- Free variables (i.e., not uninterpreted nor bound in the definition itself) - (Maybe [(Quantifier, String)]) -- Param declaration groups, if any - (Int -> String) -- Body, given the tab amount. + (Maybe [(Quantifier, T.Text)]) -- Param declaration groups, if any + (Int -> T.Text) -- Body, given the tab amount. -- | Maka a new substate from the incoming state, sharing parts as necessary inSubState :: MonadIO m => LambdaScope -> State -> (State -> m b) -> m b @@ -139,12 +141,12 @@ } -- In this case, we expect just one group of parameters, with universal quantification -extractAllUniversals :: [(Quantifier, String)] -> String +extractAllUniversals :: [(Quantifier, T.Text)] -> T.Text extractAllUniversals [(ALL, s)] = s extractAllUniversals other = error $ unlines [ "" , "*** Data.SBV.Lambda: Impossible happened. Got existential quantifiers." , "***" - , "*** Params: " ++ show other + , "*** Params: " ++ show (map (\(q, t) -> (q, T.unpack t)) other) , "***" , "*** Please report this as a bug!" ] @@ -188,8 +190,8 @@ , "*** touch for further possible enhancements." ] - sh (Defn _unints _frees Nothing body) = body 0 - sh (Defn _unints _frees (Just params) body) = "(lambda " ++ extractAllUniversals params ++ "\n" ++ body 2 ++ ")" + sh (Defn _unints _frees Nothing body) = T.unpack (body 0) + sh (Defn _unints _frees (Just params) body) = "(lambda " ++ T.unpack (extractAllUniversals params) ++ "\n" ++ T.unpack (body 2) ++ ")" shift [] = [] shift (x:xs) = intercalate "\n" (x : map tab xs) @@ -236,20 +238,20 @@ lambdaStr :: (MonadIO m, Lambda (SymbolicT m) a) => State -> LambdaScope -> Kind -> a -> m SMTLambda lambdaStr st scope k a = SMTLambda <$> lambdaGen scope mkLam st k a where mkLam (Defn _unints _frees Nothing body) = body 0 - mkLam (Defn _unints _frees (Just params) body) = "(lambda " ++ extractAllUniversals params ++ "\n" ++ body 2 ++ ")" + mkLam (Defn _unints _frees (Just params) body) = "(lambda " <> extractAllUniversals params <> "\n" <> body 2 <> ")" -- | Generic constraint generator. -constraintGen :: (MonadIO m, Constraint (SymbolicT m) a) => LambdaScope -> ([String] -> (Int -> String) -> b) -> State -> a -> m b +constraintGen :: (MonadIO m, Constraint (SymbolicT m) a) => LambdaScope -> ([String] -> (Int -> T.Text) -> b) -> State -> a -> m b constraintGen scope trans inState@State{rProgInfo} f = do -- indicate we have quantifiers liftIO $ modifyIORef' rProgInfo (\u -> u{hasQuants = True}) let mkDef (Defn deps _frees Nothing body) = trans deps body - mkDef (Defn deps _frees (Just params) body) = trans deps $ \i -> unwords (map mkGroup params) ++ "\n" - ++ body (i + 2) - ++ replicate (length params) ')' - mkGroup (ALL, s) = "(forall " ++ s - mkGroup (EX, s) = "(exists " ++ s + mkDef (Defn deps _frees (Just params) body) = trans deps $ \i -> T.unwords (map mkGroup params) <> "\n" + <> body (i + 2) + <> T.replicate (length params) ")" + mkGroup (ALL, s) = "(forall " <> s + mkGroup (EX, s) = "(exists " <> s inSubState scope inState $ \st -> mkDef <$> convert st KBool (mkConstraint st f >>= output >> pure ()) @@ -268,9 +270,9 @@ -- We allow free variables here (first arg of constraintGen). This might prove to be not kosher! constraintStr :: (MonadIO m, Constraint (SymbolicT m) a) => State -> a -> m String constraintStr = constraintGen TopLevel toStr - where toStr deps body = intercalate "\n" [ "; user defined axiom: " ++ depInfo deps - , "(assert " ++ body 2 ++ ")" - ] + where toStr deps body = T.unpack $ T.intercalate "\n" [ "; user defined axiom: " <> T.pack (depInfo deps) + , "(assert " <> body 2 <> ")" + ] depInfo [] = "" depInfo ds = "[Refers to: " ++ intercalate ", " ds ++ "]" @@ -344,7 +346,7 @@ ] | True = res - where res = Defn (nub [nm | Uninterpreted nm <- G.universeBi allOps]) + where res = Defn (nub [T.unpack nm | Uninterpreted nm <- G.universeBi allOps]) frees mbParam body @@ -374,29 +376,29 @@ | null params = Nothing | True = Just [(q, paramList (map snd l)) | l@((q, _) : _) <- pGroups] where pGroups = groupBy (\(q1, _) (q2, _) -> q1 == q2) params - paramList ps = '(' : unwords (map (\p -> '(' : show p ++ " " ++ smtType (kindOf p) ++ ")") ps) ++ ")" + paramList ps = "(" <> T.unwords (map (\p -> "(" <> showText p <> " " <> smtType (kindOf p) <> ")") ps) <> ")" body tabAmnt | null constTables , null nonConstTables , Just e <- simpleBody (map (, Nothing) constBindings ++ svBindings) out - = tab ++ e + = tab <> e | True - = intercalate "\n" $ map (tab ++) $ [mkLet sv | sv <- constBindings] - ++ [mkTable t | t <- constTables] - ++ walk svBindings nonConstTables - ++ [shift ++ show out ++ replicate totalClose ')'] + = T.intercalate "\n" $ map (tab <>) $ [mkLet sv | sv <- constBindings] + ++ [mkTable t | t <- constTables] + ++ walk svBindings nonConstTables + ++ [shift <> showText out <> T.replicate totalClose ")"] - where tab = replicate tabAmnt ' ' + where tab = T.replicate tabAmnt " " - mkBind l r = shift ++ "(let ((" ++ l ++ " " ++ r ++ "))" - mkLet (s, v) = mkBind (show s) v + mkBind l r = shift <> "(let ((" <> l <> " " <> r <> "))" + mkLet (s, v) = mkBind (showText s) v -- Align according to level. - shift = replicate (24 + 16 * (fromMaybe 0 level - 1)) ' ' + shift = T.replicate (24 + 16 * (fromMaybe 0 level - 1)) " " - mkTable (((i, ak, rk), elts), _) = mkBind nm (lambdaTable (map (const ' ') nm) ak rk elts) - where nm = "table" ++ show i + mkTable (((i, ak, rk), elts), _) = mkBind nm (lambdaTable (T.map (const ' ') nm) ak rk elts) + where nm = "table" <> showText i totalClose = length constBindings + length svBindings @@ -410,7 +412,7 @@ ++ walk rest notReady where (ready, notReady) = partition (\(need, _) -> need < getLLI nd) remaining mkLocalBind (b, Nothing) = mkLet b - mkLocalBind (b, Just l) = mkLet b ++ " ; " ++ l + mkLocalBind (b, Just l) = mkLet b <> " ; " <> T.pack l getLLI :: NodeId -> (Int, Int) getLLI (NodeId (_, mbl, i)) = (fromMaybe 0 mbl, i) @@ -420,23 +422,23 @@ -- (see https://github.com/LeventErkok/sbv/issues/733), so only do it if we're being verbose for debugging purposes. mkPretty = verbose cfg - simpleBody :: [((SV, String), Maybe String)] -> SV -> Maybe String - simpleBody [((v, e), Nothing)] o | v == o, not mkPretty || '\n' `notElem` e = Just e - simpleBody _ _ = Nothing + simpleBody :: [((SV, T.Text), Maybe String)] -> SV -> Maybe T.Text + simpleBody [((v, e), Nothing)] o | v == o, not mkPretty || not (T.any (== '\n') e) = Just e + simpleBody _ _ = Nothing assignments = F.toList (pgmAssignments pgm) constants = filter ((`notElem` [falseSV, trueSV]) . fst) consts - constBindings :: [(SV, String)] + constBindings :: [(SV, T.Text)] constBindings = map mkConst constants - where mkConst :: (SV, CV) -> (SV, String) - mkConst (sv, cv) = (sv, cvToSMTLib (roundingMode cfg) cv) + where mkConst :: (SV, CV) -> (SV, T.Text) + mkConst (sv, cv) = (sv, cvToSMTLib cv) - svBindings :: [((SV, String), Maybe String)] + svBindings :: [((SV, T.Text), Maybe String)] svBindings = map mkAsgn assignments - where mkAsgn (sv, e@(SBVApp (Label l) _)) = ((sv, T.unpack $ converter e), Just l) - mkAsgn (sv, e) = ((sv, T.unpack $ converter e), Nothing) + where mkAsgn (sv, e@(SBVApp (Label l) _)) = ((sv, converter e), Just l) + mkAsgn (sv, e) = ((sv, converter e), Nothing) converter = cvtExp cfg curProgInfo (capabilities (solver cfg)) rm tableMap @@ -453,15 +455,15 @@ -- NB. The following is dead-code, since we ensure tbls is empty -- We used to support this, but there are issues, so dropping support -- See, for instance, https://github.com/LeventErkok/sbv/issues/664 - (tableMap, constTables, nonConstTablesUnindexed) = constructTables rm consts tbls + (tableMap, constTables, nonConstTablesUnindexed) = constructTables consts tbls -- Index each non-const table with the largest index of SV it needs nonConstTables = [ (maximum ((0, 0) : [getLLI n | SV _ n <- elts]), nct) | nct@((_, elts), _) <- nonConstTablesUnindexed] - lambdaTable :: String -> Kind -> Kind -> [SV] -> String - lambdaTable extraSpace ak rk elts = "(lambda ((" ++ lv ++ " " ++ smtType ak ++ "))" ++ space ++ chain 0 elts ++ ")" - where cnst k i = T.unpack $ cvtCV rm (mkConstCV k (i::Integer)) + lambdaTable :: T.Text -> Kind -> Kind -> [SV] -> T.Text + lambdaTable extraSpace ak rk elts = "(lambda ((" <> lv <> " " <> smtType ak <> "))" <> space <> chain 0 elts <> ")" + where cnst k i = cvtCV (mkConstCV k (i::Integer)) lv = "idx" @@ -469,15 +471,15 @@ long = not (null (drop 5 elts)) space | long - = "\n " ++ extraSpace + = "\n " <> extraSpace | True = " " chain _ [] = cnst rk 0 - chain _ [x] = show x - chain i (x:xs) = "(ite (= " ++ lv ++ " " ++ cnst ak i ++ ") " - ++ show x ++ space - ++ chain (i+1) xs - ++ ")" + chain _ [x] = showText x + chain i (x:xs) = "(ite (= " <> lv <> " " <> cnst ak i <> ") " + <> showText x <> space + <> chain (i+1) xs + <> ")" {- HLint ignore module "Use second" -} diff --git a/Data/SBV/List.hs b/Data/SBV/List.hs --- a/Data/SBV/List.hs +++ b/Data/SBV/List.hs @@ -28,7 +28,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.List ( -- * Length, emptiness @@ -762,7 +762,7 @@ = literal $ P.zip xs' ys' | True = def xs ys - where def = smtFunction "sbv.zip" + where def = smtFunction "sbv.zip" $ \x y -> [sCase| tuple (x, y) of ([], _ ) -> [] (_, [] ) -> [] @@ -1348,7 +1348,7 @@ z = zIn + delta / 2 up, down :: SReal -> SReal -> SReal -> SList AlgReal - up = smtFunctionWithMeasure "EnumSymbolic.AlgReal.enumFromThenTo.up" (\start _d end -> 0 `smax` (end - start + 1), []) + up = smtFunctionWithMeasure "EnumSymbolic.AlgReal.enumFromThenTo.up" (\start _d end -> 0 `smax` (end - start + 1), []) $ \start d end -> ite (start .> end .|| d .<= 0) [] (start .: up (start + d) d end) down = smtFunctionWithMeasure "EnumSymbolic.AlgReal.enumFromThenTo.down" (\start _d end -> 0 `smax` (start - end + 1), []) $ \start d end -> ite (start .< end .|| d .>= 0) [] (start .: down (start + d) d end) diff --git a/Data/SBV/Maybe.hs b/Data/SBV/Maybe.hs --- a/Data/SBV/Maybe.hs +++ b/Data/SBV/Maybe.hs @@ -18,7 +18,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Maybe ( -- * Constructing optional values diff --git a/Data/SBV/Provers/CVC4.hs b/Data/SBV/Provers/CVC4.hs --- a/Data/SBV/Provers/CVC4.hs +++ b/Data/SBV/Provers/CVC4.hs @@ -9,12 +9,16 @@ -- The connection to the CVC4 SMT solver ----------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} + {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Provers.CVC4(cvc4) where import Data.Char (isSpace) +import qualified Data.Text as T + import Data.SBV.Core.Data import Data.SBV.SMT.SMT @@ -52,11 +56,14 @@ } } where -- CVC4 wants all input on one line - clean = map simpleSpace . noComment + clean = T.map simpleSpace . noComment - noComment "" = "" - noComment (';':cs) = noComment $ dropWhile (/= '\n') cs - noComment (c:cs) = c : noComment cs + noComment t + | T.null t = T.empty + | True = case T.break (== ';') t of + (before, rest) + | T.null rest -> before + | True -> before <> noComment (T.dropWhile (/= '\n') (T.tail rest)) simpleSpace c | isSpace c = ' ' diff --git a/Data/SBV/Provers/CVC5.hs b/Data/SBV/Provers/CVC5.hs --- a/Data/SBV/Provers/CVC5.hs +++ b/Data/SBV/Provers/CVC5.hs @@ -9,12 +9,16 @@ -- The connection to the CVC5 SMT solver ----------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} + {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Provers.CVC5(cvc5) where import Data.Char (isSpace) +import qualified Data.Text as T + import Data.SBV.Core.Data import Data.SBV.SMT.SMT @@ -52,11 +56,14 @@ } } where -- CVC5 wants all input on one line - clean = map simpleSpace . noComment + clean = T.map simpleSpace . noComment - noComment "" = "" - noComment (';':cs) = noComment $ dropWhile (/= '\n') cs - noComment (c:cs) = c : noComment cs + noComment t + | T.null t = T.empty + | True = case T.break (== ';') t of + (before, rest) + | T.null rest -> before + | True -> before <> noComment (T.dropWhile (/= '\n') (T.tail rest)) simpleSpace c | isSpace c = ' ' diff --git a/Data/SBV/Provers/Prover.hs b/Data/SBV/Provers/Prover.hs --- a/Data/SBV/Provers/Prover.hs +++ b/Data/SBV/Provers/Prover.hs @@ -15,6 +15,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -61,6 +62,7 @@ import Data.SBV.SMT.SMT import Data.SBV.SMT.Utils (debug, alignPlain) import Data.SBV.Utils.ExtractIO +import Data.SBV.Utils.Lib (showText) import Data.SBV.Utils.TDiff import Data.SBV.Lambda () -- instances only @@ -209,7 +211,7 @@ satWith cfg a = do r <- runWithQuery satArgReduce True (checkNoOptimizations >> Control.getSMTResult) cfg a SatResult <$> if validationRequested cfg then validate satArgReduce True cfg a r - else return r + else pure r -- | Generalization of 'Data.SBV.sat' dsat :: a -> m SatResult @@ -220,7 +222,7 @@ dsatWith cfg a = do r <- runWithQuery satArgReduce True (checkNoOptimizations >> Control.getSMTResult) cfg a SatResult <$> if validationRequested cfg then validate satArgReduce True cfg a r - else return r + else pure r -- | Generalization of 'Data.SBV.allSat' allSat :: a -> m AllSatResult @@ -231,8 +233,8 @@ allSatWith cfg a = do asr <- runWithQuery satArgReduce True (checkNoOptimizations >> Control.getAllSatResult) cfg a if validationRequested cfg then do rs' <- mapM (validate satArgReduce True cfg a) (allSatResults asr) - return asr{allSatResults = rs'} - else return asr + pure asr{allSatResults = rs'} + else pure asr -- | Generalization of 'Data.SBV.isSatisfiable' isSatisfiable :: a -> m Bool @@ -242,8 +244,8 @@ isSatisfiableWith :: SMTConfig -> a -> m Bool isSatisfiableWith cfg p = do r <- satWith cfg p case r of - SatResult Satisfiable{} -> return True - SatResult Unsatisfiable{} -> return False + SatResult Satisfiable{} -> pure True + SatResult Unsatisfiable{} -> pure False _ -> error $ "SBV.isSatisfiable: Received: " ++ show r -- | Generalization of 'Data.SBV.optimize' @@ -255,12 +257,12 @@ optimizeWith config style optGoal = do res <- runWithQuery satArgReduce True opt config optGoal if not (optimizeValidateConstraints config) - then return res + then pure res else let v :: SMTResult -> m SMTResult v = validate satArgReduce True config optGoal in case res of LexicographicResult m -> LexicographicResult <$> v m - IndependentResult xs -> let w [] sofar = return (reverse sofar) + IndependentResult xs -> let w [] sofar = pure (reverse sofar) w ((n, m):rest) sofar = v m >>= \m' -> w rest ((n, m') : sofar) in IndependentResult <$> w xs [] ParetoResult (b, rs) -> ParetoResult . (b, ) <$> mapM v rs @@ -273,7 +275,7 @@ , "*** Use \"sat\" for plain satisfaction" ] Just (objectives, optimizerDirectives) -> do - mapM_ (Control.send True) optimizerDirectives + mapM_ (Control.send True . T.pack) optimizerDirectives case style of Lexicographic -> LexicographicResult <$> Control.getLexicographicOptResults @@ -302,7 +304,7 @@ -- performance benefit. satConcurrentWithAny :: Satisfiable a => SMTConfig -> [Query b] -> a -> IO (Solver, NominalDiffTime, SatResult) satConcurrentWithAny solver qs a = do (slvr,time,result) <- sbvConcurrentWithAny solver go qs a - return (slvr, time, SatResult result) + pure (slvr, time, SatResult result) where go cfg a' q = runWithQuery satArgReduce True (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' -- | Find a satisfying assignment to a property using a single solver, but run @@ -310,7 +312,7 @@ -- finish. See 'satConcurrentWithAny' for more details. satConcurrentWithAll :: Satisfiable a => SMTConfig -> [Query b] -> a -> IO [(Solver, NominalDiffTime, SatResult)] satConcurrentWithAll solver qs a = do results <- sbvConcurrentWithAll solver go qs a - return $ (\(a',b,c) -> (a',b,SatResult c)) <$> results + pure $ (\(a',b,c) -> (a',b,SatResult c)) <$> results where go cfg a' q = runWithQuery satArgReduce True (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' -- | A type @a@ is provable if we can turn it into a predicate, i.e., it has to return a boolean. @@ -328,7 +330,7 @@ proveWith cfg a = do r <- runWithQuery proofArgReduce False (checkNoOptimizations >> Control.getSMTResult) cfg a ThmResult <$> if validationRequested cfg then validate proofArgReduce False cfg a r - else return r + else pure r -- | Generalization of 'Data.SBV.dprove' dprove :: a -> m ThmResult @@ -339,7 +341,7 @@ dproveWith cfg a = do r <- runWithQuery proofArgReduce False (checkNoOptimizations >> Control.getSMTResult) cfg a ThmResult <$> if validationRequested cfg then validate proofArgReduce False cfg a r - else return r + else pure r -- | Generalization of 'Data.SBV.isVacuousProof' isVacuousProof :: a -> m Bool @@ -352,9 +354,9 @@ where check = do cs <- Control.checkSat case cs of - Control.Unsat -> return True - Control.Sat -> return False - Control.DSat{} -> return False + Control.Unsat -> pure True + Control.Sat -> pure False + Control.DSat{} -> pure False Control.Unk -> error "SBV: isVacuous: Solver returned unknown!" -- | Generalization of 'Data.SBV.isTheorem' @@ -366,10 +368,10 @@ isTheoremWith cfg p = do r <- proveWith cfg p let bad = error $ "SBV.isTheorem: Received:\n" ++ show r case r of - ThmResult Unsatisfiable{} -> return True - ThmResult Satisfiable{} -> return False - ThmResult DeltaSat{} -> return False - ThmResult SatExtField{} -> return False + ThmResult Unsatisfiable{} -> pure True + ThmResult Satisfiable{} -> pure False + ThmResult DeltaSat{} -> pure False + ThmResult SatExtField{} -> pure False ThmResult Unknown{} -> bad ThmResult ProofError{} -> bad @@ -390,21 +392,21 @@ -- concurrently and return the first that finishes, killing the others proveConcurrentWithAny :: Provable a => SMTConfig -> [Query b] -> a -> IO (Solver, NominalDiffTime, ThmResult) proveConcurrentWithAny solver qs a = do (slvr,time,result) <- sbvConcurrentWithAny solver go qs a - return (slvr, time, ThmResult result) + pure (slvr, time, ThmResult result) where go cfg a' q = runWithQuery proofArgReduce False (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' -- | Prove a property by running many queries each isolated to their own thread -- concurrently and wait for each to finish returning all results proveConcurrentWithAll :: Provable a => SMTConfig -> [Query b] -> a -> IO [(Solver, NominalDiffTime, ThmResult)] proveConcurrentWithAll solver qs a = do results <- sbvConcurrentWithAll solver go qs a - return $ (\(a',b,c) -> (a',b,ThmResult c)) <$> results + pure $ (\(a',b,c) -> (a',b,ThmResult c)) <$> results where go cfg a' q = runWithQuery proofArgReduce False (do _ <- q; checkNoOptimizations >> Control.getSMTResult) cfg a' -- | Validate a model obtained from the solver validate :: MonadIO m => (a -> SymbolicT m SBool) -> Bool -> SMTConfig -> a -> SMTResult -> m SMTResult validate reducer isSAT cfg p res = case res of - Unsatisfiable{} -> return res + Unsatisfiable{} -> pure res Satisfiable _ m -> case modelBindings m of Nothing -> error "Data.SBV.validate: Impossible happened; no bindings generated during model validation." Just env -> check env @@ -419,10 +421,10 @@ , "To turn validation off, use `cfg{optimizeValidateConstraints = False}`" ] - Unknown{} -> return res - ProofError{} -> return res + Unknown{} -> pure res + ProofError{} -> pure res - where cant msg = return $ ProofError cfg (msg ++ [ "" + where cant msg = pure $ ProofError cfg (msg ++ [ "" , "Unable to validate the produced model." ]) (Just res) @@ -430,8 +432,8 @@ where modelBinds = [(T.unpack n, RegularCV v) | (NamedSymVar _ n, v) <- env] notify s - | not (verbose cfg) = return () - | True = debug cfg ["[VALIDATE] " `alignPlain` s] + | not (verbose cfg) = pure () + | True = debug cfg ["[VALIDATE] " `alignPlain` T.pack s] notify $ "Validating the model. " ++ if null env then "There are no assignments." else "Assignment:" mapM_ notify [" " ++ l | l <- lines envShown] @@ -445,7 +447,7 @@ ++ [ " " ++ l | l <- lines envShown] ++ [ "" ] - wrap tag extras = return $ ProofError cfg (tag : explain ++ extras) (Just res) + wrap tag extras = pure $ ProofError cfg (tag : explain ++ extras) (Just res) giveUp s = wrap ("Data.SBV: Cannot validate the model: " ++ s) [ "SBV's model validator is incomplete, and cannot handle this particular case." @@ -483,7 +485,7 @@ OverflowOp _ -> Just "Overflow-checking is not done concretely." Uninterpreted v | any isADT as -> Just "Models containing ADTs are currently only partially supported." - | True -> Just $ "The value depends on the uninterpreted constant " ++ show v ++ "." + | True -> Just $ "The value depends on the uninterpreted constant " ++ T.unpack v ++ "." _ -> listToMaybe $ mapMaybe why as cstrs = S.toList $ resConstraints result @@ -507,7 +509,7 @@ -- SAT: All outputs must be true satLoop [] = do notify "All outputs are satisfied. Validation complete." - return res + pure res satLoop (sv:svs) | kindOf sv /= KBool = giveUp $ "Output tied to " ++ show sv ++ " is non-boolean." @@ -521,7 +523,7 @@ -- Proof: At least one output must be false proveLoop [] somethingFailed | somethingFailed = do notify "Counterexample is validated." - return res + pure res | True = do notify "Counterexample violates none of the outputs." badModel "Counter-example violates no constraints." proveLoop (sv:svs) somethingFailed @@ -574,7 +576,7 @@ let SMTProblem{smtLibPgm} = Control.runProofOn (SMTMode QueryInternal IRun isSat cfg) QueryInternal comments res - return $ render (smtLibPgm cfg) + pure $ render (smtLibPgm cfg) checkNoOptimizations :: MonadIO m => QueryT m () checkNoOptimizations = do objectives <- Control.getObjectives @@ -591,8 +593,8 @@ instance ExtractIO m => SatisfiableM m (SymbolicT m SBool) where satArgReduce = id instance ExtractIO m => ProvableM m (SymbolicT m SBool) where proofArgReduce = id -instance ExtractIO m => SatisfiableM m SBool where satArgReduce = return -instance ExtractIO m => ProvableM m SBool where proofArgReduce = return +instance ExtractIO m => SatisfiableM m SBool where satArgReduce = pure +instance ExtractIO m => ProvableM m SBool where proofArgReduce = pure instance {-# OVERLAPPABLE #-} (ExtractIO m, SatisfiableM m a) => SatisfiableM m (SymbolicT m a) where satArgReduce a = a >>= satArgReduce instance {-# OVERLAPPABLE #-} (ExtractIO m, ProvableM m a) => ProvableM m (SymbolicT m a) where proofArgReduce a = a >>= proofArgReduce @@ -652,7 +654,7 @@ -- | Create an 'SBVs' sequence of arguments mkArgs :: MonadSymbolic m => SymValInsts as -> m (SBVs as) -mkArgs SymValsNil = return SBVsNil +mkArgs SymValsNil = pure SBVsNil mkArgs (SymValsCons insts) = SBVsCons <$> mkArgs insts <*> mkArg -- Multi-arity Functions @@ -768,14 +770,14 @@ runInThread beginTime action config = async $ do result <- action config endTime <- rnf result `seq` getCurrentTime - return (name (solver config), endTime `diffUTCTime` beginTime, result) + pure (name (solver config), endTime `diffUTCTime` beginTime, result) -- | Perform action for all given configs, return the first one that wins. Note that we do -- not wait for the other asyncs to terminate; hopefully they'll do so quickly. sbvWithAny :: NFData b => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO (Solver, NominalDiffTime, b) sbvWithAny [] _ _ = error "SBV.withAny: No solvers given!" sbvWithAny solvers what a = do beginTime <- getCurrentTime - snd `fmap` (mapM (runInThread beginTime (`what` a)) solvers >>= waitAnyFastCancel) + snd <$> (mapM (runInThread beginTime (`what` a)) solvers >>= waitAnyFastCancel) where -- Async's `waitAnyCancel` nicely blocks; so we use this variant to ignore the -- wait part for killed threads. waitAnyFastCancel asyncs = waitAny asyncs `finally` mapM_ cancelFast asyncs @@ -783,7 +785,7 @@ sbvConcurrentWithAny :: NFData c => SMTConfig -> (SMTConfig -> a -> QueryT m b -> IO c) -> [QueryT m b] -> a -> IO (Solver, NominalDiffTime, c) -sbvConcurrentWithAny solver what queries a = snd `fmap` (mapM runQueryInThread queries >>= waitAnyFastCancel) +sbvConcurrentWithAny solver what queries a = snd <$> (mapM runQueryInThread queries >>= waitAnyFastCancel) where -- Async's `waitAnyCancel` nicely blocks; so we use this variant to ignore the -- wait part for killed threads. waitAnyFastCancel asyncs = waitAny asyncs `finally` mapM_ cancelFast asyncs @@ -797,7 +799,7 @@ where runQueryInThread q = do beginTime <- getCurrentTime runInThread beginTime (\cfg -> what cfg a q) solver - go [] = return [] + go [] = pure [] go as = do (d, r) <- waitAny as -- The following filter works because the Eq instance on Async -- checks the thread-id; so we know that we're removing the @@ -805,13 +807,13 @@ -- running the same-solver (with different options), since -- they will get different thread-ids. rs <- unsafeInterleaveIO $ go (filter (/= d) as) - return (r : rs) + pure (r : rs) -- | Perform action for all given configs, return all the results. sbvWithAll :: NFData b => [SMTConfig] -> (SMTConfig -> a -> IO b) -> a -> IO [(Solver, NominalDiffTime, b)] sbvWithAll solvers what a = do beginTime <- getCurrentTime mapM (runInThread beginTime (`what` a)) solvers >>= (unsafeInterleaveIO . go) - where go [] = return [] + where go [] = pure [] go as = do (d, r) <- waitAny as -- The following filter works because the Eq instance on Async -- checks the thread-id; so we know that we're removing the @@ -819,7 +821,7 @@ -- running the same-solver (with different options), since -- they will get different thread-ids. rs <- unsafeInterleaveIO $ go (filter (/= d) as) - return (r : rs) + pure (r : rs) -- | Symbolically executable program fragments. This class is mainly used for 'safe' calls, and is sufficiently populated internally to cover most use -- cases. Users can extend it as they wish to allow 'safe' checks for SBV programs that return/take types that are user-defined. @@ -847,18 +849,18 @@ verify mkRelative (msg, cs, cond) = do let locInfo ps = let loc (f, sl) = concat [mkRelative (srcLocFile sl), ":", show (srcLocStartLine sl), ":", show (srcLocStartCol sl), ":", f] in intercalate ",\n " (map loc ps) - location = (locInfo . getCallStack) `fmap` cs + location = locInfo . getCallStack <$> cs result <- do Control.push 1 - Control.send True $ "(assert " ++ show cond ++ ")" + Control.send True $ "(assert " <> showText cond <> ")" r <- Control.getSMTResult Control.pop 1 - return r + pure r - return $ SafeResult (location, msg, result) + pure $ SafeResult (location, msg, result) instance (ExtractIO m, NFData a) => SExecutable m (SymbolicT m a) where - sName a = a >>= \r -> rnf r `seq` return () + sName a = a >>= \r -> rnf r `seq` pure () instance ExtractIO m => SExecutable m (SBV a) where sName v = sName (output v :: SymbolicT m (SBV a)) diff --git a/Data/SBV/Rational.hs b/Data/SBV/Rational.hs --- a/Data/SBV/Rational.hs +++ b/Data/SBV/Rational.hs @@ -10,6 +10,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} diff --git a/Data/SBV/SCase.hs b/Data/SBV/SCase.hs --- a/Data/SBV/SCase.hs +++ b/Data/SBV/SCase.hs @@ -14,7 +14,9 @@ -- @sCase@ are automatically treated as symbolic case-splits, enabling -- nested symbolic pattern matching. -- --- Also provides `[pCase| expr of ... |]` for proof case-splits. +-- Also provides `[pCase| expr of ... |]` for proof case-splits. Plain +-- @case@ expressions inside @pCase@ are automatically treated as nested +-- proof case-splits (generating @cases [...]@ calls). ----------------------------------------------------------------------------- {-# LANGUAGE LambdaCase #-} @@ -44,9 +46,8 @@ import Prelude hiding (fail) import qualified Prelude as P(fail) -import Data.Generics +import Data.Generics (everywhereM, mkM) import qualified Data.Map.Strict as Map -import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set) @@ -485,15 +486,15 @@ -- Variable pattern at top level: binds the scrutinee (only when used) VarP v -> let bindScrut e | v `Set.member` freeVars e = LetE [ValD (VarP v) (NormalB scrut) []] e | True = e - in pure [CWild off (fmap bindScrut mbG) (bindScrut rhs) | (mbG, rhs) <- rhss] + in pure [CWild off (bindScrut <$> mbG) (bindScrut rhs) | (mbG, rhs) <- rhss] -- As-pattern at top level: name@subpat — bind name to scrutinee, then process inner pattern AsP name subpat -> do cases <- matchToPair scrut off (Match subpat grhs locals) let bindAs e | name `Set.member` freeVars e = LetE [ValD (VarP name) (NormalB scrut) []] e | True = e - addBind (CMatch o cn ps mbG' rhs' used) = CMatch o cn ps (fmap bindAs mbG') (bindAs rhs') used - addBind (CWild o mbG' rhs') = CWild o (fmap bindAs mbG') (bindAs rhs') + addBind (CMatch o cn ps mbG' rhs' used) = CMatch o cn ps (bindAs <$> mbG') (bindAs rhs') used + addBind (CWild o mbG' rhs') = CWild o (bindAs <$> mbG') (bindAs rhs') pure (map addBind cases) _ -> fail Unknown $ unlines [ "sCase/pCase: Unsupported pattern:" @@ -565,6 +566,12 @@ (pat', guards, decs) <- flattenPat off arg subpat let asDec = ValD (VarP name) (NormalB arg) [] pure (pat', guards, asDec : decs) +-- Nested empty record pattern: Cstr{} — equivalent to Cstr with all wildcards +flattenPat off arg (RecP conName []) = do + con <- getReference off conName + DataConI _ conType _ <- reify con + let arity = countArgs conType + flattenPat off arg (ConP con [] (replicate arity WildP)) flattenPat o _ p = fail o $ unlines [ "sCase/pCase: Unsupported complex pattern match." , " Saw: " <> pprint p , "" @@ -575,7 +582,7 @@ -- We include a destructuring equality (arg .=== head arg .: tail arg) because lists use -- SMT Seq, not declare-datatypes, so the solver doesn't automatically know this relationship. -- This is critical for pCase proof progress; harmless for sCase (redundant guard in ite-chain). --- NB. For top-level list cons patterns in pCase, the same equality is added by processCases. +-- NB. For top-level list cons patterns in pCase, the same equality is added by processProofCases. flattenCons :: Offset -> Exp -> Pat -> Pat -> Q (Pat, [Exp], [Dec]) flattenCons off arg p1 p2 = do let headExpr = mkAccessorFor (Just BTList) (mkName ":") 1 arg @@ -968,26 +975,45 @@ go (CaseE s ms) = processCaseExp (repeat Unknown) s ms go e = pure e +-- | Transform nested @case@ expressions inside a TH 'Exp' into proof case-splits. +-- Like 'transformNestedCases', but generates @cases [cond ==> rhs, ...]@ instead of +-- @ite@ chains. This is what enables @case@ expressions inside @[pCase| ... |]@ to work +-- as nested proof case-splits. +transformNestedCasesProof :: Exp -> Q Exp +transformNestedCasesProof = everywhereM (mkM go) + where go :: Exp -> Q Exp + go (CaseE s ms) = processProofCaseExp s ms + go e = pure e + -- | Transform the matches of an outer sCase expression, resolving any nested -- @case@ expressions in the RHS and guards before the outer case processes them. transformMatches :: [Match] -> Q [Match] -transformMatches = mapM transformMatch +transformMatches = transformMatchesWith transformNestedCases + +-- | Transform the matches of an outer pCase expression, resolving any nested +-- @case@ expressions in the RHS and guards as proof case-splits. +transformMatchesProof :: [Match] -> Q [Match] +transformMatchesProof = transformMatchesWith transformNestedCasesProof + +-- | Generic match transformer parameterized by the nested-case handler. +transformMatchesWith :: (Exp -> Q Exp) -> [Match] -> Q [Match] +transformMatchesWith xform = mapM transformMatch where transformMatch (Match pat body locals) = do body' <- transformBody body locals' <- mapM transformDec locals pure (Match pat body' locals') - transformBody (NormalB e) = NormalB <$> transformNestedCases e + transformBody (NormalB e) = NormalB <$> xform e transformBody (GuardedB gs) = GuardedB <$> mapM transformGuarded gs transformGuarded (g, e) = do g' <- transformGuard g - e' <- transformNestedCases e + e' <- xform e pure (g', e') - transformGuard (NormalG e) = NormalG <$> transformNestedCases e + transformGuard (NormalG e) = NormalG <$> xform e transformGuard (PatG ss) = PatG <$> mapM transformStmt ss - transformStmt (NoBindS e) = NoBindS <$> transformNestedCases e + transformStmt (NoBindS e) = NoBindS <$> xform e transformStmt s = pure s transformDec (ValD p b ls) = do b' <- transformBody b @@ -1000,6 +1026,44 @@ ls' <- mapM transformDec ls pure (Clause ps b' ls') +-- | Core proof-case pipeline: given a scrutinee and matches (in TH AST form), +-- generate @cases [cond ==> rhs, ...]@. This is the proof-level counterpart of +-- 'processCaseExp', used by 'transformNestedCasesProof' to handle inner @case@ +-- expressions inside @[pCase| ... |]@. +processProofCaseExp :: Exp -> [Match] -> Q Exp +processProofCaseExp scrut0 matches0 = do + -- Recursively transform any nested case expressions as proof case-splits. + matches <- transformMatchesProof matches0 + scrut <- transformNestedCasesProof scrut0 + mbTypeInfo <- inferType "pCase" matches + let offsets = repeat Unknown + case mbTypeInfo of + Nothing -> do + allCases <- concat <$> zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches + loc <- location + checkWildcard "pCase" loc allCases + allPairs <- processProofCases scrut [] Nothing Map.empty [] allCases + let casesName = mkName "cases" + impliesName = mkName "==>" + mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r) + pure $ AppE (VarE casesName) (ListE (map mkPair allPairs)) + Just (typ, mbt) -> do + cs <- zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches + let cases = concat cs + loc <- location + cstrs <- getCstrs mbt typ + checkWildcard "pCase" loc cases + checkArities "pCase" typ cstrs cases + let allGrdVars :: Map.Map Name (Set Name) + allGrdVars = Map.fromListWith Set.union + [ (nm, maybe Set.empty freeVars mbG) + | CMatch _ nm _ mbG _ _ <- cases ] + allPairs <- processProofCases scrut cstrs mbt allGrdVars [] cases + let casesName = mkName "cases" + impliesName = mkName "==>" + mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r) + pure $ AppE (VarE casesName) (ListE (map mkPair allPairs)) + -- * pCase -- | Quasi-quoter for proof case-splits. @@ -1029,9 +1093,10 @@ case metaParse fullCase of Right (CaseE scrut0 matches0) -> do -- Transform any nested case expressions in the RHS/guards of each match. - -- This ensures inner cases become symbolic before the outer case processes them. - matches <- transformMatches matches0 - scrut <- transformNestedCases scrut0 + -- Inner case expressions become proof case-splits (cases [...]), + -- just like inner cases in sCase become symbolic ite-chains. + matches <- transformMatchesProof matches0 + scrut <- transformNestedCasesProof scrut0 mbTypeInfo <- inferType "pCase" matches case mbTypeInfo of Nothing -> do @@ -1039,7 +1104,7 @@ allCases <- concat <$> zipWithM (matchToPair scrut) (offsets ++ repeat Unknown) matches loc <- location checkWildcard "pCase" loc allCases - allPairs <- processCases scrut [] Nothing Map.empty [] allCases + allPairs <- processProofCases scrut [] Nothing Map.empty [] allCases let casesName = mkName "cases" impliesName = mkName "==>" mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r) @@ -1105,116 +1170,220 @@ cstrs <- getCstrs mbt typ -- Collect guard variables for each constructor across all arms -- (needed to suppress false "unused binding" warnings for guard-only variables) - let allGrdVars :: Map Name (Set Name) + let allGrdVars :: Map.Map Name (Set Name) allGrdVars = Map.fromListWith Set.union [ (nm, maybe Set.empty freeVars mbG) | CMatch _ nm _ mbG _ _ <- cases ] - allPairs <- processCases scrut cstrs mbt allGrdVars [] cases + allPairs <- processProofCases scrut cstrs mbt allGrdVars [] cases let casesName = mkName "cases" impliesName = mkName "==>" mkPair (g, r) = InfixE (Just g) (VarE impliesName) (Just r) pure $ AppE (VarE casesName) (ListE (map mkPair allPairs)) - -- | Process all cases linearly, accumulating prior guards. - -- Prior guards are tagged with their constructor name (Nothing for wildcards). - -- Each entry stores (constructor, fullGuard, userGuardOnly): - -- fullGuard = the complete guard expression (used for wildcard De Morgan negation) - -- userGuardOnly = Just the user guard part (used for same-constructor negation) - -- Nothing if unguarded (same-constructor arms don't negate unguarded matches) - processCases :: Exp -> [(Name, [Type])] -> Maybe BuiltinType -> Map Name (Set Name) -> [(Maybe Name, Exp, Maybe Exp)] -> [Case] -> Q [(Exp, Exp)] - processCases _ _ _ _ _ [] = pure [] - processCases scrut cstrs mbt allGrdVars priorGuards (c:rest) = case c of - CWild _ mbG rhs -> do - -- Wildcard: negate the disjunction of ALL prior full guards (De Morgan) - let allGuards = [g | (_, g, _) <- priorGuards] - baseGuard = negateAll allGuards - finalGuard = case mbG of - Nothing -> baseGuard - Just g -> sAndAll [baseGuard, g] - rest' <- processCases scrut cstrs mbt allGrdVars (priorGuards ++ [(Nothing, finalGuard, Nothing)]) rest - pure $ (finalGuard, rhs) : rest' +-- * Proof case processing - CMatch _o nm mbp mbG rhs _allUsed -> do - let ts = case lookupBase nm cstrs of - Just t -> t - Nothing -> error $ "pCase: impossible: unknown constructor " ++ nameBase nm - pats = fromMaybe (map (const WildP) ts) mbp +-- | Process all proof cases linearly, accumulating prior guards. +-- Shared between the top-level @pCase@ quasi-quoter and 'processProofCaseExp' +-- (which handles nested @case@ expressions inside @[pCase| ... |]@). +-- +-- Prior guards are tagged with their constructor name (Nothing for wildcards). +-- Each entry stores (constructor, fullGuard, userGuardOnly): +-- +-- * fullGuard = the complete guard expression (used for wildcard De Morgan negation) +-- * userGuardOnly = Just the user guard part (used for same-constructor negation), +-- Nothing if unguarded (same-constructor arms don't negate unguarded matches) +processProofCases :: Exp -> [(Name, [Type])] -> Maybe BuiltinType -> Map.Map Name (Set Name) -> [(Maybe Name, Exp, Maybe Exp)] -> [Case] -> Q [(Exp, Exp)] +processProofCases _ _ _ _ _ [] = pure [] +processProofCases scrut cstrs mbt allGrdVars priorGuards (c:rest) = case c of + CWild _ mbG rhs -> do + -- Wildcard: negate the disjunction of ALL prior full guards (De Morgan) + let allGuards = [g | (_, g, _) <- priorGuards] + baseGuard = negateAllGuards allGuards + finalGuard = case mbG of + Nothing -> baseGuard + Just g -> sAndAll [baseGuard, g] + rest' <- processProofCases scrut cstrs mbt allGrdVars (priorGuards ++ [(Nothing, finalGuard, Nothing)]) rest + pure $ (finalGuard, rhs) : rest' - -- Build let-bindings for pattern variables - args = [(i, mkAccessorFor mbt nm i scrut) | (i, _) <- zip [(1 :: Int) ..] ts] - bindings = [ ValD (VarP v) (NormalB acc) [] - | (i, acc) <- args, VarP v <- [pats !! (i - 1)] ] + CMatch _o nm mbp mbG rhs _allUsed -> do + let ts = case lookupBase nm cstrs of + Just t -> t + Nothing -> error $ "pCase: impossible: unknown constructor " ++ nameBase nm + pats = fromMaybe (map (const WildP) ts) mbp - testerGuard = mkTesterFor mbt nm scrut + -- Build let-bindings for pattern variables + args = [(i, mkAccessorFor mbt nm i scrut) | (i, _) <- zip [(1 :: Int) ..] ts] + bindings = [ ValD (VarP v) (NormalB acc) [] + | (i, acc) <- args, VarP v <- [pats !! (i - 1)] ] - -- For list cons patterns in pCase, add a destructuring equality: - -- scrut .=== head scrut .: tail scrut - -- Lists use SMT Seq (not declare-datatypes), so the solver doesn't automatically - -- know that xs = head xs .: tail xs from sNot (null xs). We must add an explicit - -- equality to give the solver this information, mirroring what 'split' does. - -- All other types (ADTs, Maybe, Either, Tuple) use declare-datatypes and get - -- these axioms for free. - -- NB. For nested list cons patterns, the same equality is added by 'flattenCons'. - destructEq - | Just BTList <- mbt, nameBase nm == ":" - = let hd = AppE (VarE (sbvName "Data.SBV.List" "head")) scrut - tl = AppE (VarE (sbvName "Data.SBV.List" "tail")) scrut - in [foldl1 AppE [VarE '(.===), scrut, InfixE (Just hd) (VarE '(.:)) (Just tl)]] - | True - = [] + testerGuard = mkTesterFor mbt nm scrut - -- Only negate prior USER guards for the SAME constructor (others are mutually exclusive) - sameUserGuards = [ ug | (Just cn, _, Just ug) <- priorGuards, sameBase cn nm ] - negPriors = map (AppE (VarE 'sNot)) sameUserGuards + -- For list cons patterns in pCase, add a destructuring equality: + -- scrut .=== head scrut .: tail scrut + -- Lists use SMT Seq (not declare-datatypes), so the solver doesn't automatically + -- know that xs = head xs .: tail xs from sNot (null xs). We must add an explicit + -- equality to give the solver this information, mirroring what 'split' does. + -- All other types (ADTs, Maybe, Either, Tuple) use declare-datatypes and get + -- these axioms for free. + -- NB. For nested list cons patterns, the same equality is added by 'flattenCons'. + destructEq + | Just BTList <- mbt, nameBase nm == ":" + = let hd = AppE (VarE (sbvName "Data.SBV.List" "head")) scrut + tl = AppE (VarE (sbvName "Data.SBV.List" "tail")) scrut + in [foldl1 AppE [VarE '(.===), scrut, InfixE (Just hd) (VarE '(.:)) (Just tl)]] + | True + = [] - -- Build the final guard (wrap user guard in bindings so pattern vars are in scope) - grdVars = maybe Set.empty freeVars mbG - grdBindings = filter (\case - ValD (VarP v) _ _ -> v `Set.member` grdVars - _ -> True) bindings - guardParts = [testerGuard] ++ destructEq ++ negPriors ++ maybe [] (pure . addLocals grdBindings) mbG - finalGuard = sAndAll guardParts + -- Only negate prior USER guards for the SAME constructor (others are mutually exclusive) + sameUserGuards = [ ug | (Just cn, _, Just ug) <- priorGuards, sameBase cn nm ] + negPriors = map (AppE (VarE 'sNot)) sameUserGuards - -- Wrap RHS with let-bindings; include all bindings except those - -- used in any guard of the same constructor but not in this RHS - -- (to avoid false "unused" warnings from GHC for guard-only variables) - cstrGrdVars = Map.findWithDefault Set.empty nm allGrdVars - rhsVars = freeVars rhs - rhs' = addLocals (filter (\case - ValD (VarP v) _ _ -> not (v `Set.member` cstrGrdVars) || v `Set.member` rhsVars - _ -> True) bindings) rhs + -- Build the final guard (wrap user guard in bindings so pattern vars are in scope) + grdVars = maybe Set.empty freeVars mbG + grdBindings = filter (\case + ValD (VarP v) _ _ -> v `Set.member` grdVars + _ -> True) bindings + guardParts = [testerGuard] ++ destructEq ++ negPriors ++ maybe [] (pure . addLocals grdBindings) mbG + finalGuard = sAndAll guardParts - -- Track: full guard for wildcard negation, user guard for same-constructor negation - userGuardOnly = case mbG of - Just g -> Just (addLocals grdBindings g) - Nothing -> Nothing - priorGuards' = priorGuards ++ [(Just nm, finalGuard, userGuardOnly)] + -- Wrap RHS with let-bindings; include all bindings except those + -- used in any guard of the same constructor but not in this RHS + -- (to avoid false "unused" warnings from GHC for guard-only variables) + cstrGrdVars = Map.findWithDefault Set.empty nm allGrdVars + rhsVars = freeVars rhs + rhs' = addLocals (filter (\case + ValD (VarP v) _ _ -> not (v `Set.member` cstrGrdVars) || v `Set.member` rhsVars + _ -> True) bindings) rhs - rest' <- processCases scrut cstrs mbt allGrdVars priorGuards' rest - pure $ (finalGuard, rhs') : rest' + -- Track: full guard for wildcard negation, user guard for same-constructor negation + userGuardOnly = case mbG of + Just g -> Just (addLocals grdBindings g) + Nothing -> Nothing + priorGuards' = priorGuards ++ [(Just nm, finalGuard, userGuardOnly)] - -- | Negate the disjunction of all given guards using De Morgan: sNot (g1 .|| g2 .|| ...) - negateAll :: [Exp] -> Exp - negateAll [] = VarE 'sTrue - negateAll gs = AppE (VarE 'sNot) (foldl1 (\a b -> foldl1 AppE [VarE '(.||), a, b]) gs) + rest' <- processProofCases scrut cstrs mbt allGrdVars priorGuards' rest + pure $ (finalGuard, rhs') : rest' +-- | Negate the disjunction of all given guards using De Morgan: sNot (g1 .|| g2 .|| ...) +negateAllGuards :: [Exp] -> Exp +negateAllGuards [] = VarE 'sTrue +negateAllGuards gs = AppE (VarE 'sNot) (foldl1 (\a b -> foldl1 AppE [VarE '(.||), a, b]) gs) + -- * Standalone helpers --- | Free variables = used – bound +-- | Free variables of an expression, respecting lexical scope. +-- A variable is free if it is used (VarE) and not bound by any enclosing +-- LetE, LamE, or CaseE at its use site. freeVars :: Exp -> Set Name -freeVars e = usedVars e Set.\\ boundVars e - where boundVars :: Exp -> Set Name - boundVars = everything Set.union (mkQ Set.empty f) - where f :: Pat -> Set Name - f (VarP n) = Set.singleton n - f (AsP n _) = Set.singleton n - f _ = Set.empty +freeVars = go Set.empty + where + go :: Set Name -> Exp -> Set Name + go bound = \case + VarE n -> if n `Set.member` bound then Set.empty else Set.singleton n + ConE {} -> Set.empty + LitE {} -> Set.empty + AppE f x -> go bound f <> go bound x + AppTypeE e _ -> go bound e + InfixE ml o mr -> maybe Set.empty (go bound) ml <> go bound o <> maybe Set.empty (go bound) mr + UInfixE l o r -> go bound l <> go bound o <> go bound r + ParensE e -> go bound e + CondE c t f -> go bound c <> go bound t <> go bound f + TupE mes -> foldMap (maybe Set.empty (go bound)) mes + UnboxedTupE mes -> foldMap (maybe Set.empty (go bound)) mes + ListE es -> foldMap (go bound) es + SigE e _ -> go bound e + RecConE _ fes -> foldMap (go bound . snd) fes + RecUpdE e fes -> go bound e <> foldMap (go bound . snd) fes + -- Binding forms: extend the bound set in the appropriate scope + LamE ps body -> go (bound <> patsNames ps) body + LetE ds body -> let bound' = bound <> decsNames ds + in foldMap (goDec bound') ds <> go bound' body + CaseE scr ms -> go bound scr <> foldMap (goMatch bound) ms + -- Fallback for other expression forms: conservatively report all + -- VarE names minus known bound (may over-report, never under-report) + other -> allVarE other Set.\\ bound - usedVars :: Exp -> Set Name - usedVars = everything Set.union (mkQ Set.empty f) - where f :: Exp -> Set Name - f (VarE n) = Set.singleton n - f _ = Set.empty + goMatch :: Set Name -> Match -> Set Name + goMatch bound (Match pat body ds) = + let bound' = bound <> patNames pat <> decsNames ds + in goBody bound' body <> foldMap (goDec bound') ds + + goBody :: Set Name -> Body -> Set Name + goBody bound (NormalB e) = go bound e + goBody bound (GuardedB gs) = foldMap (\(g, e) -> goGuard bound g <> go bound e) gs + + goGuard :: Set Name -> Guard -> Set Name + goGuard bound (NormalG e) = go bound e + goGuard _ _ = Set.empty + + goDec :: Set Name -> Dec -> Set Name + goDec bound (ValD _ body ds) = goBody bound body <> foldMap (goDec bound) ds + goDec bound (FunD _ cs) = foldMap (goClause bound) cs + goDec _ _ = Set.empty + + goClause :: Set Name -> Clause -> Set Name + goClause bound (Clause ps body ds) = + let bound' = bound <> patsNames ps <> decsNames ds + in goBody bound' body <> foldMap (goDec bound') ds + + -- Extract bound names from patterns + patNames :: Pat -> Set Name + patNames (VarP n) = Set.singleton n + patNames (AsP n p) = Set.singleton n <> patNames p + patNames (ConP _ _ ps) = patsNames ps + patNames (InfixP p1 _ p2) = patNames p1 <> patNames p2 + patNames (UInfixP p1 _ p2) = patNames p1 <> patNames p2 + patNames (TupP ps) = patsNames ps + patNames (UnboxedTupP ps) = patsNames ps + patNames (ListP ps) = patsNames ps + patNames (SigP p _) = patNames p + patNames (ParensP p) = patNames p + patNames (TildeP p) = patNames p + patNames (BangP p) = patNames p + patNames (ViewP _ p) = patNames p + patNames WildP = Set.empty + patNames (LitP _) = Set.empty + patNames _ = Set.empty + + patsNames :: [Pat] -> Set Name + patsNames = foldMap patNames + + -- Extract bound names from declarations + decsNames :: [Dec] -> Set Name + decsNames ds = Set.fromList $ [n | ValD (VarP n) _ _ <- ds] ++ [n | FunD n _ <- ds] + + -- Collect all VarE names in an expression (scope-unaware, for fallback only) + allVarE :: Exp -> Set Name + allVarE = \case + VarE n -> Set.singleton n + AppE f x -> allVarE f <> allVarE x + AppTypeE e _ -> allVarE e + InfixE ml o mr -> maybe Set.empty allVarE ml <> allVarE o <> maybe Set.empty allVarE mr + UInfixE l o r -> allVarE l <> allVarE o <> allVarE r + ParensE e -> allVarE e + CondE c t f -> allVarE c <> allVarE t <> allVarE f + TupE mes -> foldMap (maybe Set.empty allVarE) mes + UnboxedTupE mes -> foldMap (maybe Set.empty allVarE) mes + ListE es -> foldMap allVarE es + SigE e _ -> allVarE e + RecConE _ fes -> foldMap (allVarE . snd) fes + RecUpdE e fes -> allVarE e <> foldMap (allVarE . snd) fes + LamE _ body -> allVarE body + LetE ds body -> foldMap allVarEDec ds <> allVarE body + CaseE scr ms -> allVarE scr <> foldMap allVarEMatch ms + _ -> Set.empty + + allVarEMatch :: Match -> Set Name + allVarEMatch (Match _ body ds) = allVarEBody body <> foldMap allVarEDec ds + + allVarEBody :: Body -> Set Name + allVarEBody (NormalB e) = allVarE e + allVarEBody (GuardedB gs) = foldMap (\(_, e) -> allVarE e) gs + + allVarEDec :: Dec -> Set Name + allVarEDec (ValD _ body ds) = allVarEBody body <> foldMap allVarEDec ds + allVarEDec (FunD _ cs) = foldMap (\(Clause _ body ds) -> allVarEBody body <> foldMap allVarEDec ds) cs + allVarEDec _ = Set.empty -- | Count the number of arguments in a constructor type by counting arrows. -- e.g., @Integer -> String -> Bool@ has 2 arguments. diff --git a/Data/SBV/SMT/SMT.hs b/Data/SBV/SMT/SMT.hs --- a/Data/SBV/SMT/SMT.hs +++ b/Data/SBV/SMT/SMT.hs @@ -13,7 +13,9 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} @@ -60,13 +62,14 @@ import Data.Either (rights) import System.Directory (findExecutable) -import System.Environment (getEnv) +import System.Environment (getEnv, lookupEnv) import System.Exit (ExitCode(..)) -import System.IO (hClose, hFlush, hPutStrLn, hGetContents, hGetLine, hReady, hGetChar) +import System.IO (hClose, hFlush, hGetContents, hGetLine, hReady, hGetChar) import System.Process (runInteractiveProcess, waitForProcess, terminateProcess) import qualified Data.Map.Strict as M import qualified Data.Text as T +import qualified Data.Text.IO as TIO import Text.Read (readMaybe) import Data.SBV.Core.AlgReals @@ -82,7 +85,7 @@ ) import Data.SBV.Utils.PrettyNum -import Data.SBV.Utils.Lib (joinArgs, splitArgs, needsBars) +import Data.SBV.Utils.Lib (joinArgs, splitArgs, needsBars, showText) import Data.SBV.Utils.SExpr (parenDeficit, nameSupply) import qualified System.Timeout as Timeout (timeout) @@ -237,7 +240,7 @@ -- | Given a parsed model instance, transform it using @f@, and return the result. -- The default definition for this method should be sufficient in most use cases. cvtModel :: (a -> Maybe b) -> Maybe (a, [CV]) -> Maybe (b, [CV]) - cvtModel f x = x >>= \(a, r) -> f a >>= \b -> return (b, r) + cvtModel f x = x >>= \(a, r) -> f a >>= \b -> pure (b, r) {-# MINIMAL parseCVs #-} @@ -248,12 +251,12 @@ -- | Base case for 'SatModel' at unit type. Comes in handy if there are no real variables. instance SatModel () where - parseCVs xs = return ((), xs) + parseCVs xs = pure ((), xs) -- | 'Bool' as extracted from a model instance SatModel Bool where parseCVs xs = do (x, r) <- genParse KBool xs - return ((x :: Integer) /= 0, r) + pure ((x :: Integer) /= 0, r) -- | 'Word8' as extracted from a model instance SatModel Word8 where @@ -370,37 +373,37 @@ instance (SatModel a, SatModel b) => SatModel (a, b) where parseCVs as = do (a, bs) <- parseCVs as (b, cs) <- parseCVs bs - return ((a, b), cs) + pure ((a, b), cs) -- | 3-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c) => SatModel (a, b, c) where parseCVs as = do (a, bs) <- parseCVs as ((b, c), ds) <- parseCVs bs - return ((a, b, c), ds) + pure ((a, b, c), ds) -- | 4-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d) => SatModel (a, b, c, d) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d), es) <- parseCVs bs - return ((a, b, c, d), es) + pure ((a, b, c, d), es) -- | 5-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e) => SatModel (a, b, c, d, e) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d, e), fs) <- parseCVs bs - return ((a, b, c, d, e), fs) + pure ((a, b, c, d, e), fs) -- | 6-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f) => SatModel (a, b, c, d, e, f) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d, e, f), gs) <- parseCVs bs - return ((a, b, c, d, e, f), gs) + pure ((a, b, c, d, e, f), gs) -- | 7-Tuples extracted from a model instance (SatModel a, SatModel b, SatModel c, SatModel d, SatModel e, SatModel f, SatModel g) => SatModel (a, b, c, d, e, f, g) where parseCVs as = do (a, bs) <- parseCVs as ((b, c, d, e, f, g), hs) <- parseCVs bs - return ((a, b, c, d, e, f, g), hs) + pure ((a, b, c, d, e, f, g), hs) -- | Various SMT results that we can extract models out of. class Modelable a where @@ -417,7 +420,7 @@ -- | Extract a model value for a given element. Also see `getModelValues`. getModelValue :: SymVal b => String -> a -> Maybe b - getModelValue v r = fromCV `fmap` (v `M.lookup` getModelDictionary r) + getModelValue v r = fromCV <$> (v `M.lookup` getModelDictionary r) -- | A simpler variant of 'getModelAssignment' to get a model out without the fuss. extractModel :: SatModel b => a -> Maybe b @@ -518,8 +521,8 @@ displayModels arrange disp AllSatResult{allSatResults = ms} = do let models = rights (map (getModelAssignment . SatResult) ms) inds <- zipWithM display (arrange models) [(1::Int)..] - return $ last (0:inds) - where display r i = disp i r >> return i + pure $ last (0:inds) + where display r i = disp i r >> pure i -- | Show an SMTResult; generic version showSMTResult :: String -> String -> String -> String -> (Maybe String -> String) -> String -> SMTResult -> String @@ -529,7 +532,7 @@ Satisfiable _ m -> satMsgModel ++ showModel cfg m DeltaSat _ p m -> dSatMsgModel p ++ showModel cfg m SatExtField _ (SMTModel b _ _ _) -> satExtMsg ++ showModelDictionary True False cfg b - Unknown _ r -> unkMsg ++ ".\n" ++ " Reason: " `alignPlain` show r + Unknown _ r -> unkMsg ++ ".\n" ++ T.unpack (" Reason: " `alignPlain` showText r) ProofError _ [] Nothing -> "*** An error occurred. No additional information available. Try running in verbose mode." ProofError _ ls Nothing -> "*** An error occurred.\n" ++ intercalate "\n" (map ("*** " ++) ls) ProofError _ ls (Just r) -> intercalate "\n" $ [ "*** " ++ l | l <- ls] @@ -570,7 +573,7 @@ relevantVars = filter (not . ignore) allVars ignore (T.pack -> s, _) | includeEverything = False - | True = mustIgnoreVar cfg (T.unpack s) + | True = mustIgnoreVar cfg s shM (s, RegularCV v) = let vs = shCV cfg s v in ((length s, s), (vlength vs, vs)) shM (s, other) = let vs = show other in ((length s, s), (vlength vs, vs)) @@ -673,7 +676,7 @@ Just cs -> def ++ "\n" ++ cs -- | Helper function to spin off to an SMT solver. -pipeProcess :: SMTConfig -> State -> String -> [String] -> String -> (State -> IO a) -> IO a +pipeProcess :: SMTConfig -> State -> String -> [String] -> T.Text -> (State -> IO a) -> IO a pipeProcess cfg ctx execName opts pgm continuation = do mbExecPath <- findExecutable execName case mbExecPath of @@ -691,14 +694,42 @@ ]) ] +-- Communication-level timeouts (microseconds). These are NOT solver timeouts +-- (i.e., how long check-sat takes); they govern how long SBV waits for the +-- solver process to respond to individual IPC commands. +-- +-- Adjust via the @SBV_COMM_TIMEOUT_FACTOR@ environment variable (default: 1). +-- For instance, setting it to 2 doubles all communication timeouts. + +-- | Timeout for @set-option@ commands (expected to be fast). +setCommandTimeOut :: Int +setCommandTimeOut = 2_000_000 -- 2 seconds + +-- | Timeout for subsequent response lines once the solver starts responding, +-- and for heartbeat\/sync-point reads. +defaultLineTimeOut :: Int +defaultLineTimeOut = 5_000_000 -- 5 seconds + +-- | Read @SBV_COMM_TIMEOUT_FACTOR@ and return a function that scales timeout values. +-- If the variable is unset, the identity function is returned. If set to an invalid +-- value (not a positive number), an error is raised. +commTimeOutScaler :: IO (Int -> Int) +commTimeOutScaler = do + mbFactor <- lookupEnv "SBV_COMM_TIMEOUT_FACTOR" + case mbFactor of + Nothing -> pure id + Just s -> case reads s of + [(f, "")] | f > (0 :: Double) -> pure (round . (f *) . fromIntegral) + _ -> error $ "SBV_COMM_TIMEOUT_FACTOR: invalid value " ++ show s ++ ". Must be a positive number." + -- | A standard engine interface. Most solvers follow-suit here in how we "chat" to them.. standardEngine :: String -> String -> SMTEngine standardEngine envName envOptName cfg ctx pgm continuation = do - execName <- getEnv envName `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (executable (solver cfg)))) - execOpts <- (splitArgs `fmap` getEnv envOptName) `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (options (solver cfg) cfg))) + execName <- getEnv envName `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (executable (solver cfg)))) + execOpts <- (splitArgs <$> getEnv envOptName) `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (options (solver cfg) cfg))) let cfg' = cfg {solver = (solver cfg) {executable = execName, options = const execOpts}} @@ -708,15 +739,15 @@ -- communicating with it. standardSolver :: SMTConfig -- ^ The current configuration -> State -- ^ Context in which we are running - -> String -- ^ The program + -> T.Text -- ^ The program -> (State -> IO a) -- ^ The continuation -> IO a standardSolver config ctx pgm continuation = do - let msg s = debug config ["** " ++ s] + let msg s = debug config ["** " <> s] smtSolver= solver config exec = executable smtSolver opts = options smtSolver config ++ extraArgs config - msg $ "Calling: " ++ (exec ++ (if null opts then "" else " ") ++ joinArgs opts) + msg $ "Calling: " <> T.pack (exec ++ (if null opts then "" else " ") ++ joinArgs opts) rnf pgm `seq` pipeProcess config ctx exec opts pgm continuation -- | An internal type to track of solver interactions @@ -725,21 +756,40 @@ | SolverException String -- ^ Something else went wrong -- | A variant of @readProcessWithExitCode@; except it deals with SBV continuations -runSolver :: SMTConfig -> State -> FilePath -> [String] -> String -> (State -> IO a) -> IO a +runSolver :: SMTConfig -> State -> FilePath -> [String] -> T.Text -> (State -> IO a) -> IO a runSolver cfg ctx execPath opts pgm continuation - = do let nm = show (name (solver cfg)) - msg = debug cfg . map ("*** " ++) + = do scaler <- commTimeOutScaler + let nm = show (name (solver cfg)) + msg = debug cfg . map ("*** " <>) + clean = preprocess (solver cfg) -- the very first command we send heartbeat = "(set-option :print-success true)" + -- Scaled communication timeouts + setCommandTO = Just (scaler setCommandTimeOut) + defaultLineTO = Just (scaler defaultLineTimeOut) + + -- Default SBVException with solver config baked in; callers override fields as needed + solverException desc = SBVException { sbvExceptionDescription = desc + , sbvExceptionSent = Nothing + , sbvExceptionExpected = Nothing + , sbvExceptionReceived = Nothing + , sbvExceptionStdOut = Nothing + , sbvExceptionStdErr = Nothing + , sbvExceptionExitCode = Nothing + , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } } + , sbvExceptionReason = Nothing + , sbvExceptionHint = Nothing + } + (send, ask, getResponseFromSolver, terminateSolver, cleanUp, pid) <- do (inh, outh, errh, pid) <- runInteractiveProcess execPath opts Nothing Nothing - let send :: Maybe Int -> String -> IO () - send mbTimeOut command = do hPutStrLn inh (clean command) + let send :: Maybe Int -> T.Text -> IO () + send mbTimeOut command = do TIO.hPutStrLn inh (clean command) hFlush inh recordTranscript (transcript cfg) $ SentMsg command mbTimeOut @@ -748,40 +798,34 @@ where chk cmd = cmd /= heartbeat && "(set-option :" `isPrefixOf` cmd -- Send a line, get a whole s-expr. We ignore the pathetic case that there might be a string with an unbalanced parentheses in it in a response. - ask :: Maybe Int -> String -> IO String - ask mbTimeOutGiven command = - let -- If the command is a set-option call, make sure there's a timeout on it - -- This ensures that if we try to set an option before diagnostic-output - -- is redirected to stdout and the solver chokes, then we can catch it - mbTimeOut | isSetCommand (Just command) = Just 1000000 - | True = mbTimeOutGiven - - -- solvers don't respond to empty lines or comments; we just pass back + ask :: Maybe Int -> T.Text -> IO String + ask mbTimeOut command = + let -- solvers don't respond to empty lines or comments; we just pass back -- success in these cases to keep the illusion of everything has a response - cmd = dropWhile isSpace command + cmd = T.dropWhile isSpace command - in if null cmd || ";" `isPrefixOf` cmd - then return "success" + in if T.null cmd || ";" `T.isPrefixOf` cmd + then pure "success" else do send mbTimeOut command - getResponseFromSolver (Just command) mbTimeOut + getResponseFromSolver (Just (T.unpack command)) mbTimeOut -- Get a response from the solver, with an optional time-out on how long - -- to wait. Note that there's *always* a time-out of 5 seconds once we get the - -- first line of response, as while the solver might take it's time to respond, + -- to wait. Note that there's *always* a time-out once we get the + -- first line of response, as while the solver might take its time to respond, -- once it starts responding successive lines should come quickly. getResponseFromSolver :: Maybe String -> Maybe Int -> IO String getResponseFromSolver mbCommand mbTimeOut = do response <- go True 0 [] let collated = intercalate "\n" $ reverse response recordTranscript (transcript cfg) $ RecvMsg collated - return collated + pure collated where safeGetLine isFirst h = - let timeOutToUse | isSetCommand mbCommand = Just 2000000 + let timeOutToUse | isSetCommand mbCommand = setCommandTO | isFirst = mbTimeOut - | True = Just 5000000 - timeOutMsg t | isFirst = "User specified timeout of " ++ showTimeoutValue t ++ " exceeded" - | True = "A multiline complete response wasn't received before " ++ showTimeoutValue t ++ " exceeded" + | True = defaultLineTO + timeOutMsg t | isFirst = "User specified timeout of " ++ T.unpack (showTimeoutValue t) ++ " exceeded" + | True = "A multiline complete response wasn't received before " ++ T.unpack (showTimeoutValue t) ++ " exceeded" -- Like hGetLine, except it keeps getting lines if inside a string. getFullLine :: IO String @@ -798,7 +842,7 @@ if stillInside then collect True sofar' - else return sofar' + else pure sofar' -- Carefully grab things as they are ready. But don't block! collectH handle = reverse <$> coll "" @@ -815,7 +859,7 @@ Nothing -> SolverRegular <$> getFullLine Just t -> do r <- Timeout.timeout t getFullLine case r of - Just l -> return $ SolverRegular l + Just l -> pure $ SolverRegular l Nothing -> do out <- grab outh err <- grab errh -- in this case, if we have something on out/err pass that back as regular @@ -824,7 +868,7 @@ _ -> pure $ SolverTimeout (timeOutMsg t) go isFirst i sofar = do - errln <- safeGetLine isFirst outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (SolverException (show e)))) + errln <- safeGetLine isFirst outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (SolverException (show e)))) case errln of SolverRegular ln -> let !need = i + parenDeficit ln -- make sure we get *something* @@ -833,95 +877,78 @@ (';':_) -> True -- yes this does happen! I've seen z3 print out comments on stderr. _ -> False in case (empty, need <= 0) of - (True, _) -> do debug cfg ["[SKIP] " `alignPlain` ln] + (True, _) -> do debug cfg ["[SKIP] " `alignPlain` T.pack ln] go isFirst need sofar (False, False) -> go False need (ln:sofar) - (False, True) -> return (ln:sofar) + (False, True) -> pure (ln:sofar) SolverException e -> do terminateProcess pid - C.throwIO SBVException { sbvExceptionDescription = e - , sbvExceptionSent = mbCommand - , sbvExceptionExpected = Nothing - , sbvExceptionReceived = Just $ unlines (reverse sofar) - , sbvExceptionStdOut = Nothing - , sbvExceptionStdErr = Nothing - , sbvExceptionExitCode = Nothing - , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } } - , sbvExceptionReason = Nothing - , sbvExceptionHint = if "hGetLine: end of file" `isInfixOf` e - then Just [ "Solver process prematurely ended communication." - , "" - , "It is likely it was terminated because of a seg-fault." - , "Run with 'transcript=Just \"bad.smt2\"' option, and feed" - , "the generated \"bad.smt2\" file directly to the solver" - , "outside of SBV for further information." - ] - else Nothing - } + C.throwIO (solverException e) + { sbvExceptionSent = mbCommand + , sbvExceptionReceived = Just $ unlines (reverse sofar) + , sbvExceptionHint = if "hGetLine: end of file" `isInfixOf` e + then Just [ "Solver process prematurely ended communication." + , "" + , "It is likely it was terminated because of a seg-fault." + , "Run with 'transcript=Just \"bad.smt2\"' option, and feed" + , "the generated \"bad.smt2\" file directly to the solver" + , "outside of SBV for further information." + ] + else Nothing + } SolverTimeout e -> do terminateProcess pid -- NB. Do not *wait* for the process, just quit. - C.throwIO SBVException { sbvExceptionDescription = "Timeout! " ++ e - , sbvExceptionSent = mbCommand - , sbvExceptionExpected = Nothing - , sbvExceptionReceived = Just $ unlines (reverse sofar) - , sbvExceptionStdOut = Nothing - , sbvExceptionStdErr = Nothing - , sbvExceptionExitCode = Nothing - , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } } - , sbvExceptionReason = Nothing - , sbvExceptionHint = if not (verbose cfg) - then Just ["Run with 'verbose=True' for further information"] - else Nothing - } + C.throwIO (solverException ("Timeout! " ++ e)) + { sbvExceptionSent = mbCommand + , sbvExceptionReceived = Just $ unlines (reverse sofar) + , sbvExceptionHint = if not (verbose cfg) + then Just ["Run with 'verbose=True' for further information"] + else Nothing + } terminateSolver = do hClose inh outMVar <- newEmptyMVar - out <- hGetContents outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (show e))) + out <- hGetContents outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (show e))) _ <- forkIO $ C.evaluate (length out) >> putMVar outMVar () - err <- hGetContents errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (show e))) + err <- hGetContents errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (show e))) _ <- forkIO $ C.evaluate (length err) >> putMVar outMVar () takeMVar outMVar takeMVar outMVar - hClose outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return ())) - hClose errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (return ())) - ex <- waitForProcess pid `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (ExitFailure (-999)))) - return (out, err, ex) + hClose outh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure ())) + hClose errh `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure ())) + ex <- waitForProcess pid `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (ExitFailure (-999)))) + pure (out, err, ex) cleanUp maybeForwardedException = do (out, err, ex) <- terminateSolver - msg $ [ "Solver : " ++ nm - , "Exit code: " ++ show ex + msg $ [ "Solver : " <> T.pack nm + , "Exit code: " <> showText ex ] - ++ [ "Std-out : " ++ intercalate "\n " (lines out) | not (null out)] - ++ [ "Std-err : " ++ intercalate "\n " (lines err) | not (null err)] + <> [ "Std-out : " <> T.pack (intercalate "\n " (lines out)) | not (null out)] + <> [ "Std-err : " <> T.pack (intercalate "\n " (lines err)) | not (null err)] finalizeTranscript (transcript cfg) ex recordEndTime cfg ctx case (ex, maybeForwardedException) of (_, Just forwardedException) -> C.throwIO forwardedException - (ExitSuccess, _) -> return () + (ExitSuccess, _) -> pure () _ -> if ignoreExitCode cfg - then msg ["Ignoring non-zero exit code of " ++ show ex ++ " per user request!"] - else C.throwIO SBVException { sbvExceptionDescription = "Failed to complete the call to " ++ nm - , sbvExceptionSent = Nothing - , sbvExceptionExpected = Nothing - , sbvExceptionReceived = Nothing - , sbvExceptionStdOut = Just out - , sbvExceptionStdErr = Just err - , sbvExceptionExitCode = Just ex - , sbvExceptionConfig = cfg { solver = (solver cfg) { executable = execPath } } - , sbvExceptionReason = Nothing - , sbvExceptionHint = if not (verbose cfg) - then Just ["Run with 'verbose=True' for further information"] - else Nothing + then msg ["Ignoring non-zero exit code of " <> showText ex <> " per user request!"] + else C.throwIO (solverException ("Failed to complete the call to " ++ nm)) + { sbvExceptionStdOut = Just out + , sbvExceptionStdErr = Just err + , sbvExceptionExitCode = Just ex + , sbvExceptionHint = if not (verbose cfg) + then Just ["Run with 'verbose=True' for further information"] + else Nothing } - return (send, ask, getResponseFromSolver, terminateSolver, cleanUp, pid) + pure (send, ask, getResponseFromSolver, terminateSolver, cleanUp, pid) - let executeSolver = do let sendAndGetSuccess :: Maybe Int -> String -> IO () + let executeSolver = do let sendAndGetSuccess :: Maybe Int -> T.Text -> IO () sendAndGetSuccess mbTimeOut l -- The pathetic case when the solver doesn't support queries, so we pretend it responded "success" -- Currently ABC is the only such solver. @@ -934,7 +961,7 @@ ["success"] -> debug cfg ["[GOOD] " `alignPlain` l] _ -> do debug cfg ["[FAIL] " `alignPlain` l] - let isOption = "(set-option" `isPrefixOf` dropWhile isSpace l + let isOption = T.isPrefixOf "(set-option" (T.dropWhile isSpace l) reason | isOption = [ "Backend solver reports it does not support this option." , "Check the spelling, and if correct please report this as a" @@ -945,8 +972,8 @@ ] -- put a sync point here before we die so we consume everything - mbExtras <- (Right <$> getResponseFromSolver Nothing (Just 5000000)) - `C.catch` (\(e :: C.SomeException) -> handleAsync e (return (Left (show e)))) + mbExtras <- (Right <$> getResponseFromSolver Nothing defaultLineTO) + `C.catch` (\(e :: C.SomeException) -> handleAsync e (pure (Left (show e)))) -- Ignore any exceptions from last sync, pointless. let extras = case mbExtras of @@ -957,16 +984,14 @@ let out = intercalate "\n" . lines $ outOrig err = intercalate "\n" . lines $ errOrig - exc = SBVException { sbvExceptionDescription = "Unexpected non-success response from " ++ nm - , sbvExceptionSent = Just l - , sbvExceptionExpected = Just "success" - , sbvExceptionReceived = Just $ r ++ "\n" ++ extras - , sbvExceptionStdOut = Just out - , sbvExceptionStdErr = Just err - , sbvExceptionExitCode = Just ex - , sbvExceptionConfig = cfg { solver = (solver cfg) {executable = execPath } } - , sbvExceptionReason = Just reason - , sbvExceptionHint = Nothing + exc = (solverException ("Unexpected non-success response from " ++ nm)) + { sbvExceptionSent = Just (T.unpack l) + , sbvExceptionExpected = Just "success" + , sbvExceptionReceived = Just $ r ++ "\n" ++ extras + , sbvExceptionStdOut = Just out + , sbvExceptionStdErr = Just err + , sbvExceptionExitCode = Just ex + , sbvExceptionReason = Just reason } C.throwIO exc @@ -977,10 +1002,10 @@ -- First check that the solver supports :print-success let backend = name $ solver cfg if not (supportsCustomQueries (capabilities (solver cfg))) - then debug cfg ["** Skipping heart-beat for the solver " ++ show backend] - else do r <- ask (Just 5000000) heartbeat -- Give the solver 5s to respond, this should be plenty enough! + then debug cfg ["** Skipping heart-beat for the solver " <> showText backend] + else do r <- ask defaultLineTO (T.pack heartbeat) case words r of - ["success"] -> debug cfg ["[GOOD] " ++ heartbeat] + ["success"] -> debug cfg ["[GOOD] " <> T.pack heartbeat] ["unsupported"] -> error $ unlines [ "" , "*** Backend solver (" ++ show backend ++ ") does not support the command:" , "***" @@ -1002,13 +1027,13 @@ -- For push/pop support, we require :global-declarations to be true. But not all solvers -- support this. Issue it if supported. (If not, we'll reject pop calls.) if not (supportsGlobalDecls (capabilities (solver cfg))) - then debug cfg [ "** Backend solver " ++ show backend ++ " does not support global decls." + then debug cfg [ "** Backend solver " <> showText backend <> " does not support global decls." , "** Some incremental calls, such as pop, will be limited." ] else sendAndGetSuccess Nothing "(set-option :global-declarations true)" -- Now dump the program! - mapM_ (sendAndGetSuccess Nothing) (mergeSExpr (lines pgm)) + mapM_ (sendAndGetSuccess Nothing) (mergeSExpr (T.lines pgm)) -- Prepare the query context and ship it off let qs = QueryState { queryAsk = ask diff --git a/Data/SBV/SMT/SMTLib2.hs b/Data/SBV/SMT/SMTLib2.hs --- a/Data/SBV/SMT/SMTLib2.hs +++ b/Data/SBV/SMT/SMTLib2.hs @@ -35,11 +35,12 @@ import Data.SBV.SMT.Utils -import Data.SBV.Core.Symbolic ( QueryContext(..), SetOp(..), getUserName', getSV, regExpToSMTString, NROp(..) - , SMTDef(..), ResultInp(..), ProgInfo(..), SpecialRelOp(..), ADTOp(..) +import Data.SBV.Core.Symbolic ( QueryContext(..), SetOp(..), getUserName, getUserName', getSV, regExpToSMTString, NROp(..) + , SMTDef(..), SMTLambda(..), ResultInp(..), ProgInfo(..), SpecialRelOp(..), ADTOp(..) ) import Data.SBV.Utils.PrettyNum (smtRoundingMode, cvToSMTLib) +import Data.SBV.Utils.Lib (showText) import qualified Data.Generics.Uniplate.Data as G @@ -125,7 +126,6 @@ hasTuples = not . null $ tupleArities hasRational = any isRational kindInfo hasADTs = not . null $ adtsNoRM - rm = roundingMode cfg solverCaps = capabilities (solver cfg) (needsQuantifiers, needsSpecialRels) = case curProgInfo of @@ -146,19 +146,11 @@ ] nope w = [ "*** Given problem requires support for " <> T.pack w - , "*** But the chosen solver (" <> T.pack (show (name (solver cfg))) <> ") doesn't support this feature." + , "*** But the chosen solver (" <> showText (name (solver cfg)) <> ") doesn't support this feature." ] -- Some cases require all, some require none. - setAll reason = ["(set-logic " <> T.pack (showLogic Logic_ALL) <> ") ; " <> T.pack reason <> ", using catch-all."] - - isCVC5 = case name (solver cfg) of - CVC5 -> True - _ -> False - - -- If ALL is selected, use HO_ALL for CVC5 to get support for higher-order features. Yet another discrepancy. - showLogic Logic_ALL | isCVC5 = "HO_ALL" - showLogic l = show l + setAll reason = [logicString cfg Logic_ALL <> " ; " <> T.pack reason <> ", using catch-all."] -- Determining the logic is surprisingly tricky! logic :: [Text] @@ -167,14 +159,13 @@ | Just l <- case [l | SetLogic l <- solverSetOptions cfg] of [] -> Nothing [l] -> Just l - ls -> let msg = T.unlines [ "" - , "*** Only one setOption call to 'setLogic' is allowed, found: " <> T.pack (show (length ls)) - , "*** " <> T.unwords (map (T.pack . show) ls) - ] - in error $ T.unpack msg + ls -> error $ T.unpack $ T.unlines [ "" + , "*** Only one setOption call to 'setLogic' is allowed, found: " <> showText (length ls) + , "*** " <> T.unwords (map showText ls) + ] = case l of Logic_NONE -> ["; NB. Not setting the logic per user request of Logic_NONE"] - _ -> ["(set-logic " <> T.pack (showLogic l) <> ") ; NB. User specified."] + _ -> [logicString cfg l <> " ; NB. User specified."] -- There's a reason why we can't handle this problem: | Just cantDo <- doesntHandle @@ -212,26 +203,25 @@ | hasFP || hasRounding = if needsQuantifiers - then ["(set-logic ALL)"] - else if hasBVs - then ["(set-logic QF_FPBV)"] - else ["(set-logic QF_FP)"] + then [logicString cfg Logic_ALL] + else [logicString cfg (if hasBVs then QF_FPBV else QF_FP)] -- If we're in a user query context, we'll pick ALL, otherwise -- we'll stick to some bit-vector logic based on what we see in the problem. -- This is controversial, but seems to work well in practice. | True = case ctx of - QueryExternal -> ["(set-logic ALL) ; external query, using all logics."] + QueryExternal -> [logicString cfg Logic_ALL <> " ; external query, using all logics."] QueryInternal -> if supportsBitVectors solverCaps - then ["(set-logic " <> qs <> as <> ufs <> "BV)"] - else ["(set-logic ALL)"] -- fall-thru - where qs | not needsQuantifiers = "QF_" - | True = "" - as | not hasArrays = "" - | True = "A" - ufs | null uis && null tbls = "" -- we represent tables as UFs - | True = "UF" + then [logicString cfg picked] + else [logicString cfg Logic_ALL] -- fall-thru + where picked + | needsQuantifiers = Logic_ALL + | True = case (hasArrays, null uis && null tbls) of + (False, False) -> QF_UFBV + (False, True) -> QF_BV + (True, False) -> QF_AUFBV + (True, True) -> QF_ABV -- SBV always requires the production of models! getModels :: [Text] @@ -279,7 +269,7 @@ <> [ "; --- top level inputs ---"] <> concat [declareFun s (SBVType [kindOf s]) (userName s) | var <- inputs, let s = getSV var] <> [ "; --- optimization tracker variables ---" | not (null trackerVars) ] - <> concat [declareFun s (SBVType [kindOf s]) (Just ("tracks " <> T.pack nm)) | var <- trackerVars, let s = getSV var, let nm = getUserName' var] + <> concat [declareFun s (SBVType [kindOf s]) (Just ("tracks " <> getUserName var)) | var <- trackerVars, let s = getSV var] <> [ "; --- constant tables ---" ] <> concatMap (uncurry (:) . mkTable) constTables <> [ "; --- non-constant tables ---" ] @@ -303,7 +293,7 @@ = "; Automatically generated by SBV. Do not modify!" : userDefs - (tableMap, constTables, nonConstTables) = constructTables rm consts tbls + (tableMap, constTables, nonConstTables) = constructTables consts tbls delayedEqualities = concatMap snd nonConstTables @@ -346,7 +336,7 @@ userNameMap = M.fromList $ map (\nSymVar -> (getSV nSymVar, getUserName' nSymVar)) inputs userName s = case M.lookup s userNameMap of - Just u | show s /= u -> Just $ "tracks user variable " <> T.pack (show u) + Just u | show s /= u -> Just $ "tracks user variable " <> showText u _ -> Nothing -- | Declare ADTs @@ -367,7 +357,7 @@ mkC (nm, []) = T.pack nm mkC (nm, ts) = T.pack nm <> " " <> T.unwords ['(' `T.cons` mkF (nm <> "_" <> show i) t <> ")" | (i, t) <- zip [(1::Int)..] ts] - where mkF a t = "get" <> T.pack a <> " " <> T.pack (smtType t) + where mkF a t = "get" <> T.pack a <> " " <> smtType t singleADT :: (String, [(String, Kind)], [(String, [Kind])]) -> [Text] singleADT (tName, [], []) = ["(declare-sort " <> T.pack tName <> " 0) ; N.B. Uninterpreted sort."] @@ -384,7 +374,7 @@ : concatMap adtBody adts <> ["))"] - typeDecls = T.unwords ['(' `T.cons` T.pack name <> " " <> T.pack (show (length pks)) <> ")" | (name, pks, _) <- adts] + typeDecls = T.unwords ['(' `T.cons` T.pack name <> " " <> showText (length pks) <> ")" | (name, pks, _) <- adts] adtBody (_, pks, cstrs) = body where (parOpen, parClose) = parParens pks @@ -407,18 +397,18 @@ | arity == 1 = error "Data.SBV.declTuple: Unexpected one-tuple" | True = (l1 <> "(par (" <> T.unwords [param i | i <- [1..arity]] <> ")") : [pre i <> proj i <> post i | i <- [1..arity]] - where l1 = "(declare-datatypes ((SBVTuple" <> T.pack (show arity) <> " " <> T.pack (show arity) <> ")) (" - l2 = T.replicate (T.length l1) " " <> "((mkSBVTuple" <> T.pack (show arity) <> " " + where l1 = "(declare-datatypes ((SBVTuple" <> showText arity <> " " <> showText arity <> ")) (" + l2 = T.replicate (T.length l1) " " <> "((mkSBVTuple" <> showText arity <> " " tab = T.replicate (T.length l2) " " pre 1 = l2 pre _ = tab - proj i = "(proj_" <> T.pack (show i) <> "_SBVTuple" <> T.pack (show arity) <> " " <> param i <> ")" + proj i = "(proj_" <> showText i <> "_SBVTuple" <> showText arity <> " " <> param i <> ")" post i = if i == arity then ")))))" else "" - param i = "T" <> T.pack (show i) + param i = "T" <> showText i -- | Find the set of tuple sizes to declare, eg (2-tuple, 5-tuple). -- NB. We do *not* need to recursively go into list/tuple kinds here, @@ -475,14 +465,12 @@ <> concat tableAssigns -- extra constraints <> map (\(isSoft, attr, v) -> "(assert" <> (if isSoft then "-soft " else " ") <> addAnnotations attr (cvtSV v) <> ")") (F.toList cstrs) - where rm = roundingMode cfg - - newKinds = Set.toList newKs + where newKinds = Set.toList newKs declInp (getSV -> s) = declareFun s (SBVType [kindOf s]) Nothing (tableMap, allTables) = (tm, ct <> nct) - where (tm, ct, nct) = constructTables rm consts tbls + where (tm, ct, nct) = constructTables consts tbls (tableDecls, tableAssigns) = unzip $ map mkTable allTables @@ -508,7 +496,7 @@ | True = [ "(declare-fun " <> varT <> ")" <> cmnt , "(assert (= " <> var <> " " <> def <> "))" ] - where var = T.pack $ show s + where var = showText s varT = var <> " " <> svFunType [] s cmnt = maybe "" (" ; " <>) mbComment @@ -520,14 +508,14 @@ | s == falseSV || s == trueSV = [] | True - = defineFun cfg (s, cvtCV (roundingMode cfg) c) Nothing + = defineFun cfg (s, cvtCV c) Nothing -- Make a function equality of nm against the internal function fun mkRelEq :: Text -> (Text, Text) -> Kind -> Text mkRelEq nm (fun, order) ak = res where lhs = "(" <> nm <> " x y)" rhs = "((_ " <> fun <> " " <> order <> ") x y)" - tk = T.pack $ smtType ak + tk = smtType ak res = "(forall ((x " <> tk <> ") (y " <> tk <> ")) (= " <> lhs <> " " <> rhs <> "))" declUI :: ProgInfo -> (String, (Bool, Maybe [String], SBVType)) -> [Text] @@ -550,7 +538,7 @@ getDeps (_, (SMTDef _ d _ _, _)) = d mkDecl Nothing rt = "() " <> rt - mkDecl (Just p) rt = T.pack p <> " " <> rt + mkDecl (Just p) rt = p <> " " <> rt sorted = DG.stronglyConnComp (map mkNode ds) @@ -561,7 +549,7 @@ xs -> declUserDefMulti xs declUserDef isRec (nm, (SMTDef fk deps param body, ty)) = - "; " <> T.pack nm <> " :: " <> T.pack (show ty) <> recursive <> frees <> "\n" <> s + "; " <> T.pack nm <> " :: " <> showText ty <> recursive <> frees <> "\n" <> s where (recursive, definer) | isRec = (" [Recursive]", "define-fun-rec") | True = ("", "define-fun") @@ -569,17 +557,17 @@ frees | null otherDeps = "" | True = " [Refers to: " <> T.intercalate ", " (map T.pack otherDeps) <> "]" - decl = mkDecl param (T.pack $ smtType fk) + decl = mkDecl param (smtType fk) - s = "(" <> definer <> " " <> T.pack nm <> " " <> decl <> "\n" <> T.pack (body 2) <> ")" + s = "(" <> definer <> " " <> T.pack nm <> " " <> decl <> "\n" <> body 2 <> ")" -- declare a bunch of mutually-recursive functions declUserDefMulti bs = render $ map collect bs where collect (nm, (SMTDef fk deps param body, ty)) = (deps, nm, ty, "(" <> T.pack nm <> " " <> decl <> ")", body 3) - where decl = mkDecl param (T.pack $ smtType fk) + where decl = mkDecl param (smtType fk) render defs = T.intercalate "\n" $ - [ "; " <> T.intercalate ", " [T.pack n <> " :: " <> T.pack (show ty) | (_, n, ty, _, _) <- defs] + [ "; " <> T.intercalate ", " [T.pack n <> " :: " <> showText ty | (_, n, ty, _, _) <- defs] , "(define-funs-rec" ] <> [ open i <> param d <> close1 i | (i, d) <- zip [1..] defs] @@ -589,8 +577,8 @@ param (_deps, _nm, _ty, p, _body) = p - dump (deps, nm, ty, _, body) = "; Definition of: " <> T.pack nm <> " :: " <> T.pack (show ty) <> ". [Refers to: " <> T.intercalate ", " (map T.pack deps) <> "]" - <> "\n" <> T.pack body + dump (deps, nm, ty, _, body) = "; Definition of: " <> T.pack nm <> " :: " <> showText ty <> ". [Refers to: " <> T.intercalate ", " (map T.pack deps) <> "]" + <> "\n" <> body ld = length defs @@ -599,12 +587,12 @@ mkTable :: (((Int, Kind, Kind), [SV]), [Text]) -> (Text, [Text]) mkTable (((i, ak, rk), _elts), is) = (decl, zipWith wrap [(0::Int)..] is <> setup) - where t = "table" <> T.pack (show i) - decl = "(declare-fun " <> t <> " (" <> T.pack (smtType ak) <> ") " <> T.pack (smtType rk) <> ")" + where t = "table" <> showText i + decl = "(declare-fun " <> t <> " (" <> smtType ak <> ") " <> smtType rk <> ")" -- Arrange for initializers - mkInit idx = "table" <> T.pack (show i) <> "_initializer_" <> T.pack (show (idx :: Int)) - initializer = "table" <> T.pack (show i) <> "_initializer" + mkInit idx = "table" <> showText i <> "_initializer_" <> showText (idx :: Int) + initializer = "table" <> showText i <> "_initializer" wrap index s = "(define-fun " <> mkInit index <> " () Bool " <> s <> ")" @@ -621,32 +609,32 @@ ] nonConstTable :: (((Int, Kind, Kind), [SV]), [Text]) -> Text nonConstTable (((i, ak, rk), _elts), _) = decl - where t = "table" <> T.pack (show i) - decl = "(declare-fun " <> t <> " (" <> T.pack (smtType ak) <> ") " <> T.pack (smtType rk) <> ")" + where t = "table" <> showText i + decl = "(declare-fun " <> t <> " (" <> smtType ak <> ") " <> smtType rk <> ")" -constructTables :: RoundingMode -> [(SV, CV)] -> [((Int, Kind, Kind), [SV])] +constructTables :: [(SV, CV)] -> [((Int, Kind, Kind), [SV])] -> ( IM.IntMap Text -- table enumeration , [(((Int, Kind, Kind), [SV]), [Text])] -- constant tables , [(((Int, Kind, Kind), [SV]), [Text])] -- non-constant tables ) -constructTables rm consts tbls = (tableMap, constTables, nonConstTables) - where allTables = [(t, genTableData rm (map fst consts) t) | t <- tbls] +constructTables consts tbls = (tableMap, constTables, nonConstTables) + where allTables = [(t, genTableData (map fst consts) t) | t <- tbls] constTables = [(t, d) | (t, Left d) <- allTables] nonConstTables = [(t, d) | (t, Right d) <- allTables] tableMap = IM.fromList $ map grab allTables - grab (((t, _, _), _), _) = (t, "table" <> T.pack (show t)) + grab (((t, _, _), _), _) = (t, "table" <> showText t) -- Left if all constants, Right if otherwise -genTableData :: RoundingMode -> [SV] -> ((Int, Kind, Kind), [SV]) -> Either [Text] [Text] -genTableData rm consts ((i, aknd, _), elts) +genTableData :: [SV] -> ((Int, Kind, Kind), [SV]) -> Either [Text] [Text] +genTableData consts ((i, aknd, _), elts) | null post = Left (map (mkEntry . snd) pre) | True = Right (map (mkEntry . snd) (pre ++ post)) where (pre, post) = partition fst (zipWith mkElt elts [(0::Int)..]) - t = "table" <> T.pack (show i) + t = "table" <> showText i mkElt x k = (isReady, (idx, cvtSV x)) - where idx = cvtCV rm (mkConstCV aknd k) + where idx = cvtCV (mkConstCV aknd k) isReady = x `Set.member` constsSet mkEntry (idx, v) = "(= (" <> t <> " " <> idx <> ") " <> v <> ")" @@ -654,30 +642,29 @@ constsSet = Set.fromList consts svType :: SV -> Text -svType s = T.pack $ smtType (kindOf s) +svType s = smtType (kindOf s) svFunType :: [SV] -> SV -> Text svFunType ss s = "(" <> T.unwords (map svType ss) <> ") " <> svType s cvtType :: SBVType -> Text cvtType (SBVType []) = error "SBV.SMT.SMTLib2.cvtType: internal: received an empty type!" -cvtType (SBVType xs) = "(" <> T.unwords (map (T.pack . smtType) body) <> ") " <> T.pack (smtType ret) +cvtType (SBVType xs) = "(" <> T.unwords (map smtType body) <> ") " <> smtType ret where (body, ret) = (init xs, last xs) type TableMap = IM.IntMap Text -- Present an SV, simply show cvtSV :: SV -> Text -cvtSV = T.pack . show +cvtSV = showText -cvtCV :: RoundingMode -> CV -> Text -cvtCV = T.pack .* cvToSMTLib - where (.*) = (.) . (.) +cvtCV :: CV -> Text +cvtCV = cvToSMTLib getTable :: TableMap -> Int -> Text getTable m i | Just tn <- i `IM.lookup` m = tn - | True = "table" <> T.pack (show i) + | True = "table" <> showText i cvtExp :: SMTConfig -> ProgInfo -> SolverCapabilities -> RoundingMode -> TableMap -> SBVExpr -> Text cvtExp cfg curProgInfo caps rm tableMap expr@(SBVApp _ arguments) = sh expr @@ -701,7 +688,7 @@ ensureBVOrBool = bvOp || boolOp || bad ensureBV = bvOp || bad - addRM s = s <> " " <> T.pack (smtRoundingMode rm) + addRM s = s <> " " <> smtRoundingMode rm isZ3 = case name (solver cfg) of Z3 -> True @@ -737,7 +724,7 @@ mkAbs x cmp neg = "(ite " <> ltz <> " " <> nx <> " " <> x <> ")" where ltz = "(" <> cmp <> " " <> x <> " " <> z <> ")" nx = "(" <> neg <> " " <> x <> ")" - z = cvtCV rm (mkConstCV (kindOf (hd "liftAbs.arguments" arguments)) (0::Integer)) + z = cvtCV (mkConstCV (kindOf (hd "liftAbs.arguments" arguments)) (0::Integer)) lift2B bOp vOp | boolOp = lift2 bOp @@ -842,24 +829,24 @@ KTuple k -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected tuple valued index: " ++ show k KArray k1 k2 -> error $ "SBV.SMT.SMTLib2.cvtExp: unexpected array valued index: " ++ show (k1, k2) - mkCnst = cvtCV rm . mkConstCV (kindOf i) + mkCnst = cvtCV . mkConstCV (kindOf i) le0 = "(" <> less <> " " <> cvtSV i <> " " <> mkCnst 0 <> ")" gtl = "(" <> leq <> " " <> mkCnst l <> " " <> cvtSV i <> ")" sh (SBVApp (KindCast f t) [a]) = handleKindCast f t (cvtSV a) - sh (SBVApp (ArrayInit (Left (f, t))) [a]) = "((as const (Array " <> T.pack (smtType f) <> " " <> T.pack (smtType t) <> ")) " <> cvtSV a <> ")" - sh (SBVApp (ArrayInit (Right s)) []) = T.pack $ show s - sh (SBVApp ReadArray [a, i]) = "(select " <> cvtSV a <> " " <> cvtSV i <> ")" - sh (SBVApp WriteArray [a, i, e]) = "(store " <> cvtSV a <> " " <> cvtSV i <> " " <> cvtSV e <> ")" + sh (SBVApp (ArrayInit (Left (f, t))) [a]) = "((as const (Array " <> smtType f <> " " <> smtType t <> ")) " <> cvtSV a <> ")" + sh (SBVApp (ArrayInit (Right (SMTLambda s))) []) = s + sh (SBVApp ReadArray [a, i]) = "(select " <> cvtSV a <> " " <> cvtSV i <> ")" + sh (SBVApp WriteArray [a, i, e]) = "(store " <> cvtSV a <> " " <> cvtSV i <> " " <> cvtSV e <> ")" - sh (SBVApp (Uninterpreted nm) []) = T.pack nm - sh (SBVApp (Uninterpreted nm) args) = "(" <> T.pack nm <> " " <> T.unwords (map cvtSV args) <> ")" + sh (SBVApp (Uninterpreted nm) []) = nm + sh (SBVApp (Uninterpreted nm) args) = "(" <> nm <> " " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (ADTOp aop) args) = handleADT caps aop args - sh (SBVApp (QuantifiedBool i) []) = T.pack i - sh (SBVApp (QuantifiedBool i) args) = error $ "SBV.SMT.SMTLib2.cvtExp: unexpected arguments to quantified boolean: " ++ show (i, args) + sh (SBVApp (QuantifiedBool i) []) = i + sh (SBVApp (QuantifiedBool i) args) = error $ "SBV.SMT.SMTLib2.cvtExp: unexpected arguments to quantified boolean: " ++ show (T.unpack i, args) sh a@(SBVApp (SpecialRelOp k o) args) | not (null args) @@ -870,16 +857,16 @@ Nothing -> error $ unlines [ "SBV.SMT.SMTLib2.cvtExp: Cannot find " ++ show o ++ " in the special-relations list." , "Known relations: " ++ intercalate ", " (map show specialRels) ] - asrt nm fun = mkRelEq (T.pack nm) (T.pack fun, T.pack $ show order) k + asrt nm fun = mkRelEq (T.pack nm) (T.pack fun, showText order) k in case o of IsPartialOrder nm -> asrt nm "partial-order" IsLinearOrder nm -> asrt nm "linear-order" IsTreeOrder nm -> asrt nm "tree-order" IsPiecewiseLinearOrder nm -> asrt nm "piecewise-linear-order" - sh (SBVApp (Divides n) [a]) = "((_ divisible " <> T.pack (show n) <> ") " <> cvtSV a <> ")" + sh (SBVApp (Divides n) [a]) = "((_ divisible " <> showText n <> ") " <> cvtSV a <> ")" - sh (SBVApp (Extract i j) [a]) | ensureBV = "((_ extract " <> T.pack (show i) <> " " <> T.pack (show j) <> ") " <> cvtSV a <> ")" + sh (SBVApp (Extract i j) [a]) | ensureBV = "((_ extract " <> showText i <> " " <> showText j <> ") " <> cvtSV a <> ")" sh (SBVApp (Rol i) [a]) | bvOp = rot "rotate_left" i a @@ -898,11 +885,11 @@ | True = bad sh (SBVApp (ZeroExtend i) [a]) - | bvOp = "((_ zero_extend " <> T.pack (show i) <> ") " <> cvtSV a <> ")" + | bvOp = "((_ zero_extend " <> showText i <> ") " <> cvtSV a <> ")" | True = bad sh (SBVApp (SignExtend i) [a]) - | bvOp = "((_ sign_extend " <> T.pack (show i) <> ") " <> cvtSV a <> ")" + | bvOp = "((_ sign_extend " <> showText i <> ") " <> cvtSV a <> ")" | True = bad sh (SBVApp op args) @@ -921,7 +908,7 @@ sh (SBVApp (Label _) [a]) = cvtSV a -- This won't be reached; but just in case! sh (SBVApp (IEEEFP (FP_Cast kFrom kTo m)) args) = handleFPCast kFrom kTo (cvtSV m) (T.unwords (map cvtSV args)) - sh (SBVApp (IEEEFP w ) args) = "(" <> T.pack (show w) <> " " <> T.unwords (map cvtSV args) <> ")" + sh (SBVApp (IEEEFP w ) args) = "(" <> showText w <> " " <> T.unwords (map cvtSV args) <> ")" -- Some non-linear operators are supported by z3/CVC5 specifically, so do the custom translation Otherwise -- we pass them along. @@ -930,26 +917,26 @@ sh (SBVApp (NonLinear NR_Pow) [a, b]) | isZ3 || isCVC5 = "(^ " <> cvtSV a <> " " <> cvtSV b <> ")" - sh (SBVApp (NonLinear w) args) = "(" <> T.pack (show w) <> " " <> T.unwords (map cvtSV args) <> ")" + sh (SBVApp (NonLinear w) args) = "(" <> showText w <> " " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (PseudoBoolean pb) args) | hasPB = handlePB pb args' | True = reducePB pb args' where args' = map cvtSV args - sh (SBVApp (OverflowOp op) args) = "(" <> T.pack (show op) <> " " <> T.unwords (map cvtSV args) <> ")" + sh (SBVApp (OverflowOp op) args) = "(" <> showText op <> " " <> T.unwords (map cvtSV args) <> ")" -- Note the unfortunate reversal in StrInRe.. - sh (SBVApp (StrOp (StrInRe r)) args) = "(str.in_re " <> T.unwords (map cvtSV args) <> " " <> T.pack (regExpToSMTString r) <> ")" - sh (SBVApp (StrOp op) args) = "(" <> T.pack (show op) <> " " <> T.unwords (map cvtSV args) <> ")" + sh (SBVApp (StrOp (StrInRe r)) args) = "(str.in_re " <> T.unwords (map cvtSV args) <> " " <> regExpToSMTString r <> ")" + sh (SBVApp (StrOp op) args) = "(" <> showText op <> " " <> T.unwords (map cvtSV args) <> ")" - sh (SBVApp (RegExOp o@RegExEq{}) []) = T.pack (show o) - sh (SBVApp (RegExOp o@RegExNEq{}) []) = T.pack (show o) + sh (SBVApp (RegExOp o@RegExEq{}) []) = showText o + sh (SBVApp (RegExOp o@RegExNEq{}) []) = showText o -- Sequences. The only interesting thing here is that unit over KChar is a no-op since SMTLib doesn't distinguish -- Strings and Characters, but SBV does. sh (SBVApp (SeqOp (SeqUnit KChar)) [a]) = cvtSV a - sh (SBVApp (SeqOp op) args) = "(" <> T.pack (show op) <> " " <> T.unwords (map cvtSV args) <> ")" + sh (SBVApp (SeqOp op) args) = "(" <> showText op <> " " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (SetOp SetEqual) args) = "(= " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (SetOp SetMember) [e, s]) = "(select " <> cvtSV s <> " " <> cvtSV e <> ")" @@ -962,8 +949,8 @@ sh (SBVApp (SetOp SetComplement) args) = "(complement " <> T.unwords (map cvtSV args) <> ")" sh (SBVApp (TupleConstructor 0) []) = "mkSBVTuple0" - sh (SBVApp (TupleConstructor n) args) = "((as mkSBVTuple" <> T.pack (show n) <> " " <> T.pack (smtType (KTuple (map kindOf args))) <> ") " <> T.unwords (map cvtSV args) <> ")" - sh (SBVApp (TupleAccess i n) [tup]) = "(proj_" <> T.pack (show i) <> "_SBVTuple" <> T.pack (show n) <> " " <> cvtSV tup <> ")" + sh (SBVApp (TupleConstructor n) args) = "((as mkSBVTuple" <> showText n <> " " <> smtType (KTuple (map kindOf args)) <> ") " <> T.unwords (map cvtSV args) <> ")" + sh (SBVApp (TupleAccess i n) [tup]) = "(proj_" <> showText i <> "_SBVTuple" <> showText n <> " " <> cvtSV tup <> ")" sh (SBVApp RationalConstructor [t, b]) = "(SBV.Rational " <> cvtSV t <> " " <> cvtSV b <> ")" @@ -1088,7 +1075,7 @@ ] declareFun :: SV -> SBVType -> Maybe Text -> [Text] -declareFun sv = declareName (T.pack $ show sv) +declareFun sv = declareName (showText sv) -- If we have a char, we have to make sure it's and SMTLib string of length exactly one -- If we have a rational, we have to make sure the denominator is > 0 @@ -1113,8 +1100,8 @@ resultVar | needsQuant = "result" | True = s - argList = ["a" <> T.pack (show i) | (i, _) <- zip [1::Int ..] args] - argTList = ["(" <> a <> " " <> T.pack (smtType k) <> ")" | (a, k) <- zip argList args] + argList = ["a" <> showText i | (i, _) <- zip [1::Int ..] args] + argTList = ["(" <> a <> " " <> smtType k <> ")" | (a, k) <- zip argList args] resultExp = "(" <> s <> " " <> T.unwords argList <> ")" restrict | noCharOrRat = [] @@ -1159,25 +1146,25 @@ walk _d nm f k@KString {} = f k nm walk d nm f (KList k) | charRatFree k = [] - | True = let fnm = "seq" <> T.pack (show d) + | True = let fnm = "seq" <> showText d cstrs = walk (d+1) ("(seq.nth " <> nm <> " " <> fnm <> ")") f k - in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> T.pack (smtType KUnbounded) <> ")) (=> (and (>= " <> fnm <> " 0) (< " <> fnm <> " (seq.len " <> nm <> "))) " <> hole <> "))"] + in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> smtType KUnbounded <> ")) (=> (and (>= " <> fnm <> " 0) (< " <> fnm <> " (seq.len " <> nm <> "))) " <> hole <> "))"] walk d nm f (KSet k) | charRatFree k = [] - | True = let fnm = "set" <> T.pack (show d) + | True = let fnm = "set" <> showText d cstrs = walk (d+1) nm (\sk snm -> ["(=> (select " <> snm <> " " <> fnm <> ") " <> c <> ")" | c <- f sk fnm]) k - in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> T.pack (smtType k) <> ")) " <> hole <> ")"] - walk d nm f (KTuple ks) = let tt = "SBVTuple" <> T.pack (show (length ks)) - project i = "(proj_" <> T.pack (show i) <> "_" <> tt <> " " <> nm <> ")" + in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> smtType k <> ")) " <> hole <> ")"] + walk d nm f (KTuple ks) = let tt = "SBVTuple" <> showText (length ks) + project i = "(proj_" <> showText i <> "_" <> tt <> " " <> nm <> ")" nmks = [(project i, k) | (i, k) <- zip [1::Int ..] ks] in concatMap (\(n, k) -> walk (d+1) n f k) nmks walk d nm f (KArray k1 k2) | all charRatFree [k1, k2] = [] - | True = let fnm = "array" <> T.pack (show d) + | True = let fnm = "array" <> showText d cstrs = walk (d+1) ("(select " <> nm <> " " <> fnm <> ")") f k2 - in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> T.pack (smtType k1) <> ")) " <> hole <> ")"] + in mkAnd cstrs $ \hole -> ["(forall ((" <> fnm <> " " <> smtType k1 <> ")) " <> hole <> ")"] walk d nm f (KADT ty dict pureFS) = let fs = [(c, map (substituteADTVars ty dict) ks) | (c, ks) <- pureFS] - nmks = [("(get" <> T.pack c <> "_" <> T.pack (show i) <> " " <> nm <> ")", k) | (c, ks) <- fs, (i, k) <- zip [(1::Int)..] ks] + nmks = [("(get" <> T.pack c <> "_" <> showText i <> " " <> nm <> ")", k) | (c, ks) <- fs, (i, k) <- zip [(1::Int)..] ks] in concatMap (\(n, k) -> walk (d+1) n f k) nmks ----------------------------------------------------------------------------------------------- @@ -1219,7 +1206,7 @@ simplify KDouble = KFP 11 53 simplify k = k - size (eb, sb) = T.pack (show eb) <> " " <> T.pack (show sb) + size (eb, sb) = showText eb <> " " <> showText sb -- To go and back from Ints, we detour through reals cast KUnbounded (KFP eb sb) a = "(_ to_fp " <> size (eb, sb) <> ") " <> rm <> " (to_real " <> a <> ")" @@ -1232,8 +1219,8 @@ cast KFP{} (KFP eb sb) a = addRM a $ "(_ to_fp " <> size (eb, sb) <> ")" -- From float/double - cast KFP{} (KBounded False m) a = addRM a $ "(_ fp.to_ubv " <> T.pack (show m) <> ")" - cast KFP{} (KBounded True m) a = addRM a $ "(_ fp.to_sbv " <> T.pack (show m) <> ")" + cast KFP{} (KBounded False m) a = addRM a $ "(_ fp.to_ubv " <> showText m <> ")" + cast KFP{} (KBounded True m) a = addRM a $ "(_ fp.to_sbv " <> showText m <> ")" -- To real cast KFP{} KReal a = "fp.to_real" <> " " <> a @@ -1242,7 +1229,7 @@ cast f d _ = error $ "SBV.SMTLib2: Unexpected FPCast from: " ++ show f ++ " to " ++ show d rot :: Text -> Int -> SV -> Text -rot o c x = "((_ " <> o <> " " <> T.pack (show c) <> ") " <> cvtSV x <> ")" +rot o c x = "((_ " <> o <> " " <> showText c <> ") " <> cvtSV x <> ")" shft :: Text -> Text -> SV -> SV -> Text shft oW oS x c = "(" <> o <> " " <> cvtSV x <> " " <> cvtSV c <> ")" @@ -1254,13 +1241,13 @@ [] -> f _ -> "(" <> f <> " " <> T.unwords (map cvtSV args) <> ")" where f = case op of - ADTConstructor nm k -> ascribe (T.pack nm) k + ADTConstructor nm k -> ascribe nm k ADTTester nm k -> if supportsDirectTesters caps - then T.pack nm - else ascribe (T.pack nm) k - ADTAccessor nm _ -> T.pack nm + then nm + else ascribe nm k + ADTAccessor nm _ -> nm - ascribe nm k = "(as " <> nm <> " " <> T.pack (smtType k) <> ")" + ascribe nm k = "(as " <> nm <> " " <> smtType k <> ")" -- Various casts handleKindCast :: Kind -> Kind -> Text -> Text @@ -1277,7 +1264,7 @@ KUnbounded -> case kTo of KReal -> "(to_real " <> a <> ")" - KBounded _ n -> "((_ int_to_bv " <> T.pack (show n) <> ") " <> a <> ")" + KBounded _ n -> "((_ int_to_bv " <> showText n <> ") " <> a <> ")" _ -> tryFPCast KReal -> case kTo of @@ -1290,7 +1277,7 @@ -- Otherwise complain tryFPCast | any (\k -> isFloat k || isDouble k) [kFrom, kTo] - = handleFPCast kFrom kTo (T.pack $ smtRoundingMode RoundNearestTiesToEven) a + = handleFPCast kFrom kTo (smtRoundingMode RoundNearestTiesToEven) a | True = error $ "SBV.SMTLib2: Unexpected cast from: " ++ show kFrom ++ " to " ++ show kTo @@ -1299,36 +1286,36 @@ | m == n = a | True = extract (n - 1) - signExtend i = "((_ sign_extend " <> T.pack (show i) <> ") " <> a <> ")" - zeroExtend i = "((_ zero_extend " <> T.pack (show i) <> ") " <> a <> ")" - extract i = "((_ extract " <> T.pack (show i) <> " 0) " <> a <> ")" + signExtend i = "((_ sign_extend " <> showText i <> ") " <> a <> ")" + zeroExtend i = "((_ zero_extend " <> showText i <> ") " <> a <> ")" + extract i = "((_ extract " <> showText i <> " 0) " <> a <> ")" -- Translation of pseudo-booleans, in case the solver supports them handlePB :: PBOp -> [Text] -> Text -handlePB (PB_AtMost k) args = "((_ at-most " <> T.pack (show k) <> ") " <> T.unwords args <> ")" -handlePB (PB_AtLeast k) args = "((_ at-least " <> T.pack (show k) <> ") " <> T.unwords args <> ")" -handlePB (PB_Exactly k) args = "((_ pbeq " <> T.unwords (map (T.pack . show) (k : replicate (length args) 1)) <> ") " <> T.unwords args <> ")" -handlePB (PB_Eq cs k) args = "((_ pbeq " <> T.unwords (map (T.pack . show) (k : cs)) <> ") " <> T.unwords args <> ")" -handlePB (PB_Le cs k) args = "((_ pble " <> T.unwords (map (T.pack . show) (k : cs)) <> ") " <> T.unwords args <> ")" -handlePB (PB_Ge cs k) args = "((_ pbge " <> T.unwords (map (T.pack . show) (k : cs)) <> ") " <> T.unwords args <> ")" +handlePB (PB_AtMost k) args = "((_ at-most " <> showText k <> ") " <> T.unwords args <> ")" +handlePB (PB_AtLeast k) args = "((_ at-least " <> showText k <> ") " <> T.unwords args <> ")" +handlePB (PB_Exactly k) args = "((_ pbeq " <> T.unwords (map showText (k : replicate (length args) 1)) <> ") " <> T.unwords args <> ")" +handlePB (PB_Eq cs k) args = "((_ pbeq " <> T.unwords (map showText (k : cs)) <> ") " <> T.unwords args <> ")" +handlePB (PB_Le cs k) args = "((_ pble " <> T.unwords (map showText (k : cs)) <> ") " <> T.unwords args <> ")" +handlePB (PB_Ge cs k) args = "((_ pbge " <> T.unwords (map showText (k : cs)) <> ") " <> T.unwords args <> ")" -- Translation of pseudo-booleans, in case the solver does *not* support them reducePB :: PBOp -> [Text] -> Text reducePB op args = case op of - PB_AtMost k -> "(<= " <> addIf (repeat 1) <> " " <> T.pack (show k) <> ")" - PB_AtLeast k -> "(>= " <> addIf (repeat 1) <> " " <> T.pack (show k) <> ")" - PB_Exactly k -> "(= " <> addIf (repeat 1) <> " " <> T.pack (show k) <> ")" - PB_Le cs k -> "(<= " <> addIf cs <> " " <> T.pack (show k) <> ")" - PB_Ge cs k -> "(>= " <> addIf cs <> " " <> T.pack (show k) <> ")" - PB_Eq cs k -> "(= " <> addIf cs <> " " <> T.pack (show k) <> ")" + PB_AtMost k -> "(<= " <> addIf (repeat 1) <> " " <> showText k <> ")" + PB_AtLeast k -> "(>= " <> addIf (repeat 1) <> " " <> showText k <> ")" + PB_Exactly k -> "(= " <> addIf (repeat 1) <> " " <> showText k <> ")" + PB_Le cs k -> "(<= " <> addIf cs <> " " <> showText k <> ")" + PB_Ge cs k -> "(>= " <> addIf cs <> " " <> showText k <> ")" + PB_Eq cs k -> "(= " <> addIf cs <> " " <> showText k <> ")" where addIf :: [Int] -> Text - addIf cs = "(+ " <> T.unwords ["(ite " <> a <> " " <> T.pack (show c) <> " 0)" | (a, c) <- zip args cs] <> ")" + addIf cs = "(+ " <> T.unwords ["(ite " <> a <> " " <> showText c <> " 0)" | (a, c) <- zip args cs] <> ")" -- | Translate an option setting to SMTLib. Note the SetLogic/SetInfo discrepancy. setSMTOption :: SMTConfig -> SMTOption -> Text setSMTOption cfg = set - where set (DiagnosticOutputChannel f) = opt [":diagnostic-output-channel", T.pack $ show f] + where set (DiagnosticOutputChannel f) = opt [":diagnostic-output-channel", showText f] set (ProduceAssertions b) = opt [":produce-assertions", smtBool b] set (ProduceAssignments b) = opt [":produce-assignments", smtBool b] set (ProduceProofs b) = opt [":produce-proofs", smtBool b] @@ -1336,30 +1323,47 @@ set (ProduceUnsatAssumptions b) = opt [":produce-unsat-assumptions", smtBool b] set (ProduceUnsatCores b) = opt [":produce-unsat-cores", smtBool b] set (ProduceAbducts b) = opt [":produce-abducts", smtBool b] - set (RandomSeed i) = opt [":random-seed", T.pack $ show i] - set (ReproducibleResourceLimit i) = opt [":reproducible-resource-limit", T.pack $ show i] - set (SMTVerbosity i) = opt [":verbosity", T.pack $ show i] + set (RandomSeed i) = opt [":random-seed", showText i] + set (ReproducibleResourceLimit i) = opt [":reproducible-resource-limit", showText i] + set (SMTVerbosity i) = opt [":verbosity", showText i] set (OptionKeyword k as) = opt (T.pack k : map T.pack as) - set (SetLogic l) = logic l + set (SetLogic l) = logicString cfg l set (SetInfo k as) = info (T.pack k : map T.pack as) set (SetTimeOut i) = opt $ timeOut i opt xs = "(set-option " <> T.unwords xs <> ")" info xs = "(set-info " <> T.unwords xs <> ")" - logic Logic_NONE = "; NB. not setting the logic per user request of Logic_NONE" - logic l = "(set-logic " <> T.pack (show l) <> ")" - -- timeout is not standard. We distinguish between CVC/Z3. All else follows z3 -- The value is in milliseconds, which is how z3/CVC interpret it timeOut i = case name (solver cfg) of - CVC4 -> [":tlimit-per", T.pack $ show i] - CVC5 -> [":tlimit-per", T.pack $ show i] - _ -> [":timeout", T.pack $ show i] + CVC4 -> [":tlimit-per", showText i] + CVC5 -> [":tlimit-per", showText i] + _ -> [":timeout", showText i] -- SMTLib's True/False is spelled differently than Haskell's. smtBool :: Bool -> Text smtBool True = "true" smtBool False = "false" + +-- | Set the logic, accounting for solver inconsistencies. +logicString :: SMTConfig -> Logic -> Text +logicString cfg = pick + where + slvr = name (solver cfg) + + -- This is more or less showText, but with exceptions: + -- + -- Logic_ALL : HO_ALL for CVC5 to get support for higher-order features. + -- QF_FPBV : Bitwuzla calls it QF_BVFP. See: https://github.com/LeventErkok/sbv/issues/774 + -- Logic_NONE: Sets nothing, just sets a comment + pick Logic_ALL | CVC5 <- slvr = wrap "HO_ALL" + pick QF_FPBV | Bitwuzla <- slvr = wrap "QF_BVFP" + pick Logic_NONE = "; NB. not setting the logic per user request of Logic_NONE" + + -- Fall thru + pick l = wrap (showText l) + + wrap l = "(set-logic " <> l <> ")" {- HLint ignore module "Use record patterns" -} diff --git a/Data/SBV/SMT/Utils.hs b/Data/SBV/SMT/Utils.hs --- a/Data/SBV/SMT/Utils.hs +++ b/Data/SBV/SMT/Utils.hs @@ -19,7 +19,6 @@ , SMTLibIncConverter , addAnnotations , showTimeoutValue - , alignDiagnostic , alignPlain , debug , mergeSExpr @@ -40,7 +39,7 @@ import Data.SBV.Core.Data import Data.SBV.Core.Symbolic (QueryContext, CnstMap, SMTDef, ResultInp(..), ProgInfo(..), startTime) -import Data.SBV.Utils.Lib (joinArgs) +import Data.SBV.Utils.Lib (joinArgs, showText) import Data.SBV.Utils.TDiff (Timing(..), showTDiff) import Data.IORef (writeIORef) @@ -48,12 +47,12 @@ import Data.Char (isSpace) import Data.Maybe (fromMaybe) -import Data.List (intercalate) import qualified Data.Set as Set (Set) import qualified Data.Sequence as S (Seq) -import qualified Data.Text as T +import qualified Data.Text as T +import qualified Data.Text.IO as TIO import Data.Text (Text) import System.Directory (findExecutable) @@ -98,63 +97,67 @@ sanitize c = [c] -- | Show a millisecond time-out value somewhat nicely -showTimeoutValue :: Int -> String +showTimeoutValue :: Int -> Text showTimeoutValue i = case (i `quotRem` 1000000, i `quotRem` 500000) of - ((s, 0), _) -> shows s "s" - (_, (hs, 0)) -> shows (fromIntegral hs / (2::Float)) "s" - _ -> shows i "ms" + ((s, 0), _) -> showText s <> "s" + (_, (hs, 0)) -> showText (fromIntegral hs / (2::Float)) <> "s" + _ -> showText i <> "ms" -- | Nicely align a potentially multi-line message with some tag, but prefix with three stars -alignDiagnostic :: String -> String -> String +alignDiagnostic :: Text -> Text -> Text alignDiagnostic = alignWithPrefix "*** " -- | Nicely align a potentially multi-line message with some tag, no prefix. -alignPlain :: String -> String -> String +alignPlain :: Text -> Text -> Text alignPlain = alignWithPrefix "" -- | Align with some given prefix -alignWithPrefix :: String -> String -> String -> String -alignWithPrefix pre tag multi = intercalate "\n" $ zipWith (++) (tag : repeat (pre ++ replicate (length tag - length pre) ' ')) (filter (not . null) (lines multi)) +alignWithPrefix :: Text -> Text -> Text -> Text +alignWithPrefix pre tag multi = T.intercalate "\n" $ zipWith (<>) (tag : repeat (pre <> T.replicate (T.length tag - T.length pre) " ")) (filter (not . T.null) (T.lines multi)) -- | Diagnostic message when verbose -debug :: MonadIO m => SMTConfig -> [String] -> m () +debug :: MonadIO m => SMTConfig -> [Text] -> m () debug cfg - | not (verbose cfg) = const (return ()) - | Just f <- redirectVerbose cfg = liftIO . mapM_ (appendFile f . (++ "\n")) - | True = liftIO . mapM_ putStrLn + | not (verbose cfg) = const (pure ()) + | Just f <- redirectVerbose cfg = liftIO . mapM_ (\t -> TIO.appendFile f (t <> "\n")) + | True = liftIO . mapM_ TIO.putStrLn -- | In case the SMT-Lib solver returns a response over multiple lines, compress them so we have -- each S-Expression spanning only a single line. -mergeSExpr :: [String] -> [String] +mergeSExpr :: [Text] -> [Text] mergeSExpr [] = [] mergeSExpr (x:xs) | d == 0 = x : mergeSExpr xs - | True = let (f, r) = grab d xs in unlines (x:f) : mergeSExpr r + | True = let (f, r) = grab d xs in T.unlines (x:f) : mergeSExpr r where d = parenDiff x - parenDiff :: String -> Int + parenDiff :: Text -> Int parenDiff = go 0 - where go i "" = i - go i ('(':cs) = let i'= i+1 in i' `seq` go i' cs - go i (')':cs) = let i'= i-1 in i' `seq` go i' cs - go i ('"':cs) = go i (skipString cs) - go i ('|':cs) = go i (skipBar cs) - go i (';':cs) = go i (drop 1 (dropWhile (/= '\n') cs)) - go i (_ :cs) = go i cs + where go i t = case T.uncons t of + Nothing -> i + Just ('(', r) -> let i' = i+1 in i' `seq` go i' r + Just (')', r) -> let i' = i-1 in i' `seq` go i' r + Just ('"', r) -> go i (skipString r) + Just ('|', r) -> go i (skipBar r) + Just (';', r) -> go i (T.drop 1 (T.dropWhile (/= '\n') r)) + Just (_, r) -> go i r grab i ls | i <= 0 = ([], ls) grab _ [] = ([], []) grab i (l:ls) = let (a, b) = grab (i+parenDiff l) ls in (l:a, b) - skipString ('"':'"':cs) = skipString cs - skipString ('"':cs) = cs - skipString (_:cs) = skipString cs - skipString [] = [] -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore! + skipString t = case T.uncons t of + Nothing -> T.empty -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore! + Just ('"', r) -> case T.uncons r of + Just ('"', r') -> skipString r' -- escaped quote + _ -> r -- end of string + Just (_, r) -> skipString r - skipBar ('|':cs) = cs - skipBar (_:cs) = skipBar cs - skipBar [] = [] -- Oh dear, line finished, but the string didn't. We're in trouble. Ignore! + skipBar t = case T.uncons t of + Nothing -> T.empty -- Oh dear, line finished, but the bar didn't. We're in trouble. Ignore! + Just ('|', r) -> r + Just (_, r) -> skipBar r -- | An exception thrown from SBV. If the solver ever responds with a non-success value for a command, -- SBV will throw an t'SBVException', it so the user can process it as required. The provided 'Show' instance @@ -192,42 +195,42 @@ } = let grp1 = [ "" - , "*** Data.SBV: " ++ sbvExceptionDescription ++ ":" + , "*** Data.SBV: " <> T.pack sbvExceptionDescription <> ":" ] - grp2 = ["*** Sent : " `alignDiagnostic` snt | Just snt <- [sbvExceptionSent], not $ null snt ] - ++ ["*** Expected : " `alignDiagnostic` excp | Just excp <- [sbvExceptionExpected], not $ null excp] - ++ ["*** Received : " `alignDiagnostic` rcvd | Just rcvd <- [sbvExceptionReceived], not $ null rcvd] + grp2 = ["*** Sent : " `alignDiagnostic` T.pack snt | Just snt <- [sbvExceptionSent], not $ null snt ] + <> ["*** Expected : " `alignDiagnostic` T.pack excp | Just excp <- [sbvExceptionExpected], not $ null excp] + <> ["*** Received : " `alignDiagnostic` T.pack rcvd | Just rcvd <- [sbvExceptionReceived], not $ null rcvd] - grp3 = ["*** Stdout : " `alignDiagnostic` out | Just out <- [sbvExceptionStdOut], not $ null out ] - ++ ["*** Stderr : " `alignDiagnostic` err | Just err <- [sbvExceptionStdErr], not $ null err ] - ++ ["*** Exit code : " `alignDiagnostic` show ec | Just ec <- [sbvExceptionExitCode] ] - ++ ["*** Executable: " `alignDiagnostic` executable (solver sbvExceptionConfig) ] - ++ ["*** Options : " `alignDiagnostic` joinArgs (options (solver sbvExceptionConfig) sbvExceptionConfig) ] + grp3 = ["*** Stdout : " `alignDiagnostic` T.pack out | Just out <- [sbvExceptionStdOut], not $ null out ] + <> ["*** Stderr : " `alignDiagnostic` T.pack err | Just err <- [sbvExceptionStdErr], not $ null err ] + <> ["*** Exit code : " `alignDiagnostic` showText ec | Just ec <- [sbvExceptionExitCode] ] + <> ["*** Executable: " `alignDiagnostic` T.pack (executable (solver sbvExceptionConfig)) ] + <> ["*** Options : " `alignDiagnostic` T.pack (joinArgs (options (solver sbvExceptionConfig) sbvExceptionConfig))] - grp4 = ["*** Reason : " `alignDiagnostic` unlines rsn | Just rsn <- [sbvExceptionReason]] - ++ ["*** Hint : " `alignDiagnostic` unlines hnt | Just hnt <- [sbvExceptionHint ]] + grp4 = ["*** Reason : " `alignDiagnostic` T.pack (unlines rsn) | Just rsn <- [sbvExceptionReason]] + <> ["*** Hint : " `alignDiagnostic` T.pack (unlines hnt) | Just hnt <- [sbvExceptionHint ]] join [] = [] join [x] = x join (g:gs) = case join gs of [] -> g - rest -> g ++ ["***"] ++ rest + rest -> g <> ["***"] <> rest - in unlines $ join [grp1, grp2, grp3, grp4] + in T.unpack $ T.unlines $ join [grp1, grp2, grp3, grp4] -- | Compute and report the end time recordEndTime :: SMTConfig -> State -> IO () recordEndTime SMTConfig{timing} state = case timing of - NoTiming -> return () + NoTiming -> pure () PrintTiming -> do e <- elapsed putStrLn $ "*** SBV: Elapsed time: " ++ showTDiff e SaveTiming here -> writeIORef here =<< elapsed - where elapsed = getCurrentTime >>= \end -> return $ diffUTCTime end (startTime state) + where elapsed = getCurrentTime >>= \end -> pure $ diffUTCTime end (startTime state) -- | Start a transcript file, if requested. startTranscript :: Maybe FilePath -> SMTConfig -> IO () -startTranscript Nothing _ = return () +startTranscript Nothing _ = pure () startTranscript (Just f) cfg = do ts <- show <$> getZonedTime mbExecPath <- findExecutable (executable (solver cfg)) writeFile f $ start ts mbExecPath @@ -246,7 +249,7 @@ -- | Finish up the transcript file. finalizeTranscript :: Maybe FilePath -> ExitCode -> IO () -finalizeTranscript Nothing _ = return () +finalizeTranscript Nothing _ = pure () finalizeTranscript (Just f) ec = do ts <- show <$> getZonedTime appendFile f $ end ts where end ts = unlines [ "" @@ -260,31 +263,31 @@ ] -- Kind of things we can record -data TranscriptMsg = SentMsg String (Maybe Int) -- ^ Message sent, and time-out if any +data TranscriptMsg = SentMsg Text (Maybe Int) -- ^ Message sent, and time-out if any | RecvMsg String -- ^ Message received - | DebugMsg String -- ^ A debug message; neither sent nor received + | DebugMsg Text -- ^ A debug message; neither sent nor received -- If requested, record in the transcript file recordTranscript :: Maybe FilePath -> TranscriptMsg -> IO () -recordTranscript Nothing _ = return () +recordTranscript Nothing _ = pure () recordTranscript (Just f) m = do tsPre <- formatTime defaultTimeLocale "; [%T%Q" <$> getZonedTime let ts = take 15 $ tsPre ++ repeat '0' case m of - SentMsg sent mbTimeOut -> appendFile f $ unlines $ (ts ++ "] " ++ to mbTimeOut ++ "Sending:") : lines sent + SentMsg sent mbTimeOut -> TIO.appendFile f $ T.unlines $ (T.pack ts <> "] " <> to mbTimeOut <> "Sending:") : T.lines sent RecvMsg recv -> appendFile f $ unlines $ case lines (dropWhile isSpace recv) of [] -> [ts ++ "] Received: "] -- can't really happen. [x] -> [ts ++ "] Received: " ++ x] xs -> (ts ++ "] Received: ") : map ("; " ++) xs - DebugMsg msg -> let tag = ts ++ "] " - emp = ';' : drop 1 (map (const ' ') tag) - in appendFile f $ unlines $ zipWith (++) (tag : repeat emp) (lines msg) + DebugMsg msg -> let tag = T.pack ts <> "] " + emp = T.cons ';' (T.replicate (T.length tag - 1) " ") + in TIO.appendFile f $ T.unlines $ zipWith (<>) (tag : repeat emp) (T.lines msg) where to Nothing = "" - to (Just i) = "[Timeout: " ++ showTimeoutValue i ++ "] " + to (Just i) = "[Timeout: " <> showTimeoutValue i <> "] " {-# INLINE recordTranscript #-} -- Record the exception recordException :: Maybe FilePath -> String -> IO () -recordException Nothing _ = return () +recordException Nothing _ = pure () recordException (Just f) m = do ts <- show <$> getZonedTime appendFile f $ exc ts where exc ts = unlines $ [ "" diff --git a/Data/SBV/Set.hs b/Data/SBV/Set.hs --- a/Data/SBV/Set.hs +++ b/Data/SBV/Set.hs @@ -22,7 +22,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} diff --git a/Data/SBV/TP.hs b/Data/SBV/TP.hs --- a/Data/SBV/TP.hs +++ b/Data/SBV/TP.hs @@ -48,7 +48,10 @@ , sorry -- * Running TP proofs - , TP, runTP, runTPWith, tpQuiet, tpRibbon, tpStats, tpAsms + , TP, runTP, runTPWith, tpQuiet, tpStats, tpAsms + + -- * Dry run guards + , whenDryRun, unlessDryRun -- * Measure helpers for smtFunctionWithMeasure , measureLemma, measureLemmaWith diff --git a/Data/SBV/TP/Kernel.hs b/Data/SBV/TP/Kernel.hs --- a/Data/SBV/TP/Kernel.hs +++ b/Data/SBV/TP/Kernel.hs @@ -14,6 +14,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -42,6 +43,7 @@ import Data.SBV.SMT.SMT import Data.SBV.Core.Model import Data.SBV.Provers.Prover +import Data.SBV.Utils.Lib (showText) import Data.SBV.TP.Utils @@ -259,34 +261,36 @@ -- measureLemma proof uses the function whose measure is currently being checked. checkNewMeasures :: SMTConfig -> State -> TPState -> IO () checkNewMeasures cfg@SMTConfig{tpOptions = TPOptions{measuresBeingVerified}} st tpSt = do - checks <- readIORef (rMeasureChecks st) - verified <- readIORef (measuresVerified tpSt) - productive <- readIORef (productiveVerified tpSt) - let allVerified = verified `Set.union` productive - allNames = Set.fromList (map (\(n, _, _) -> n) checks) - new = [(n, p, c) | (n, p, c) <- checks, n `Set.notMember` allVerified, n `Set.notMember` measuresBeingVerified] - skipped = [n | (n, _, _) <- checks, n `Set.notMember` allVerified, n `Set.member` measuresBeingVerified] + isDry <- readIORef (dryRun tpSt) + unless isDry $ do + checks <- readIORef (rMeasureChecks st) + verified <- readIORef (measuresVerified tpSt) + productive <- readIORef (productiveVerified tpSt) + let allVerified = verified `Set.union` productive + allNames = Set.fromList (map (\(n, _, _) -> n) checks) + new = [(n, p, c) | (n, p, c) <- checks, n `Set.notMember` allVerified, n `Set.notMember` measuresBeingVerified] + skipped = [n | (n, _, _) <- checks, n `Set.notMember` allVerified, n `Set.member` measuresBeingVerified] - msg s | not (verbose cfg) - = pure () - | Just f <- redirectVerbose cfg - = appendFile f (s ++ "\n") - | True - = putStrLn s + msg s | not (verbose cfg) + = pure () + | Just f <- redirectVerbose cfg + = appendFile f (s ++ "\n") + | True + = putStrLn s - unless (null new && null skipped) $ - msg $ "[MEASURE] checkNewMeasures: " ++ show (length new) ++ " to verify" - ++ (if null skipped then "" else ", " ++ show (length skipped) ++ " skipped (being verified): " ++ show skipped) + unless (null new && null skipped) $ + msg $ "[MEASURE] checkNewMeasures: " ++ show (length new) ++ " to verify" + ++ (if null skipped then "" else ", " ++ show (length skipped) ++ " skipped (being verified): " ++ show skipped) - modifyIORef' (measuresEncountered tpSt) (Set.union allNames) - let verify (n, isProductive, c) = do - msg $ "[MEASURE] checkNewMeasures: verifying " ++ n - () <- c cfg - msg $ "[MEASURE] checkNewMeasures: " ++ n ++ " verified" - if isProductive - then modifyIORef' (productiveVerified tpSt) (Set.insert n) - else modifyIORef' (measuresVerified tpSt) (Set.insert n) - mapM_ verify new + modifyIORef' (measuresEncountered tpSt) (Set.union allNames) + let verify (n, isProductive, c) = do + msg $ "[MEASURE] checkNewMeasures: verifying " ++ n + () <- c cfg + msg $ "[MEASURE] checkNewMeasures: " ++ n ++ " verified" + if isProductive + then modifyIORef' (productiveVerified tpSt) (Set.insert n) + else modifyIORef' (measuresVerified tpSt) (Set.insert n) + mapM_ verify new -- | Capture the general flow of a proof-step. Note that this is the only point where we call the backend solver -- in a TP proof. @@ -303,12 +307,18 @@ -> m r smtProofStep cfg@SMTConfig{verbose, tpOptions = TPOptions{printStats}} tpState tag level ctx mbAssumptions prop disps unsat = do - case mbAssumptions of - Nothing -> do queryDebug ["; smtProofStep: No context value to push."] - check - Just asm -> do queryDebug ["; smtProofStep: Pushing in the context: " ++ show asm] - inNewAssertionStack $ do constrain asm - check + isDry <- liftIO $ readIORef (dryRun tpState) + if isDry + then do -- Dry run: record width, skip solver, report success + tab <- liftIO $ startTP cfg verbose tag level ctx + liftIO $ modifyIORef' (maxRibbon tpState) (max tab) + liftIO $ unsat (tab, Nothing) + else case mbAssumptions of + Nothing -> do queryDebug ["; smtProofStep: No context value to push."] + check + Just asm -> do queryDebug ["; smtProofStep: Pushing in the context: " <> showText asm] + inNewAssertionStack $ do constrain asm + check where check = do tab <- liftIO $ startTP cfg verbose tag level ctx @@ -339,13 +349,13 @@ TPProofStep False s _ ss -> intercalate "." (s : ss) unknown = do r <- getUnknownReason - liftIO $ do putStrLn $ "\n*** Failed to prove " ++ fullNm ++ "." - putStrLn $ "\n*** Solver reported: " ++ show r + liftIO $ do message cfg $ "\n*** Failed to prove " ++ fullNm ++ ".\n" + message cfg $ "\n*** Solver reported: " ++ show r ++ "\n" die -- What to do if the proof fails cex = do - liftIO $ putStrLn $ "\n*** Failed to prove " ++ fullNm ++ "." + liftIO $ message cfg $ "\n*** Failed to prove " ++ fullNm ++ ".\n" res <- case ctx of TPProofStep{} -> do mapM_ (uncurry sObserve) disps @@ -364,6 +374,6 @@ pure $ skolemize (qNot prop) pure res - liftIO $ print $ ThmResult res + liftIO $ message cfg $ show (ThmResult res) ++ "\n" die diff --git a/Data/SBV/TP/TP.hs b/Data/SBV/TP/TP.hs --- a/Data/SBV/TP/TP.hs +++ b/Data/SBV/TP/TP.hs @@ -13,6 +13,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -31,7 +32,8 @@ , induct, inductWith , sInduct, sInductWith , sorry - , TP, runTP, runTPWith, tpQuiet, tpRibbon, tpStats, tpAsms + , TP, runTP, runTPWith, tpQuiet, tpStats, tpAsms + , whenDryRun, unlessDryRun , measureLemma, measureLemmaWith , (|-), (|->), (⊢), (=:), (≡), (??), (∵), split, split2, cases, (==>), (⟹), qed, trivial, contradiction , qc, qcWith @@ -44,6 +46,8 @@ import Data.SBV.Core.Data (SBV(..), SVal(..)) import qualified Data.SBV.Core.Symbolic as S (sObserve) +import qualified Data.Text as T + import Data.SBV.Core.Symbolic (rSkipMeasureChecks, rNoTermCheckFunctions) import Data.SBV.Core.Operations (svEqual) import Data.SBV.Control hiding (getProof, (|->)) @@ -53,6 +57,7 @@ import qualified Data.SBV.List as SL +import Control.Exception (SomeException) import Control.Monad (when) import Control.Monad.Trans (liftIO) import Data.IORef (readIORef, writeIORef, modifyIORef') @@ -161,11 +166,11 @@ {-# MINIMAL calcSteps #-} calcSteps :: (SymVal t, EqSymbolic (SBV t)) => a -> StepArgs a t -> Symbolic (SBool, CalcStrategy) - calc nm p steps = getTPConfig >>= \cfg -> calcWith cfg nm p steps - calcWith cfg nm p steps = getTPConfig >>= \cfg' -> calcGeneric False (tpMergeCfg cfg cfg') nm p steps + calc nm p steps = getTPConfig >>= \cfg -> calcWith cfg nm p steps + calcWith cfg nm p steps = getTPConfig >>= \cfg' -> calcGeneric (tpMergeCfg cfg cfg') nm p steps - calcGeneric :: (SymVal t, EqSymbolic (SBV t), Proposition a) => Bool -> SMTConfig -> String -> a -> StepArgs a t -> TP (Proof a) - calcGeneric tagTheorem cfg nm result steps = do + calcGeneric :: (SymVal t, EqSymbolic (SBV t), Proposition a) => SMTConfig -> String -> a -> StepArgs a t -> TP (Proof a) + calcGeneric cfg nm result steps = do cached <- lookupProofCache result case cached of Just prf -> returnCachedProof cfg nm prf @@ -179,7 +184,10 @@ qSaturateSavingObservables result -- make sure we saturate the result, i.e., get all it's UI's, types etc. pop out - message cfg $ (if tagTheorem then "Theorem" else "Lemma") ++ ": " ++ nm ++ "\n" + let header = "Lemma: " ++ nm + message cfg $ header ++ "\n" + liftIO $ do isDry <- readIORef (dryRun tpSt) + when isDry $ modifyIORef' (maxRibbon tpSt) (max (length header)) (calcGoal, strategy@CalcStrategy {calcIntros, calcProofTree}) <- calcSteps result steps @@ -234,7 +242,7 @@ proveProofTree cfg tpSt nm (result, resultBool) initialHypotheses calcProofTree uniq quickCheckInstance = do results <- walk initialHypotheses 1 ([1], calcProofTree) - queryDebug [nm ++ ": Proof end: proving the result:"] + queryDebug [T.pack nm <> ": Proof end: proving the result:"] mbStartTime <- getTimeStampIf printStats st <- symbolicEnv @@ -370,6 +378,8 @@ liftIO $ do tab <- startTP cfg (verbose cfg) "Step" level (TPProofStep False nm (getHelperText hs') stepName) + isDry <- readIORef (dryRun tpSt) + when isDry $ modifyIORef' (maxRibbon tpSt) (max tab) (mbT, r) <- timeIf printStats $ quickCheckWithResult qcArg{QC.chatty = verbose cfg} $ quickCheckInstance bn @@ -559,8 +569,8 @@ -- partial correctness is guaranteed if non-terminating functions are involved. inductWith :: (Proposition a, SymVal t, EqSymbolic (SBV t)) => SMTConfig -> String -> a -> (Proof (IHType a) -> IHArg a -> IStepArgs a t) -> TP (Proof a) - induct nm p steps = getTPConfig >>= \cfg -> inductWith cfg nm p steps - inductWith cfg nm p steps = getTPConfig >>= \cfg' -> inductionEngine RegularInduction False (tpMergeCfg cfg cfg') nm p (inductionStrategy p steps) + induct nm p steps = getTPConfig >>= \cfg -> inductWith cfg nm p steps + inductWith cfg nm p steps = getTPConfig >>= \cfg' -> inductionEngine RegularInduction (tpMergeCfg cfg cfg') nm p (inductionStrategy p steps) -- | Internal, shouldn't be needed outside the library {-# MINIMAL inductionStrategy #-} @@ -578,16 +588,16 @@ -- partial correctness is guaranteed if non-terminating functions are involved. sInductWith :: (Proposition a, Zero m, SymVal t, EqSymbolic (SBV t)) => SMTConfig -> String -> a -> (MeasureArgs a m, [ProofObj]) -> (Proof a -> StepArgs a t) -> TP (Proof a) - sInduct nm p mhs steps = getTPConfig >>= \cfg -> sInductWith cfg nm p mhs steps - sInductWith cfg nm p mhs steps = getTPConfig >>= \cfg' -> inductionEngine GeneralInduction False (tpMergeCfg cfg cfg') nm p (sInductionStrategy p mhs steps) + sInduct nm p mhs steps = getTPConfig >>= \cfg -> sInductWith cfg nm p mhs steps + sInductWith cfg nm p mhs steps = getTPConfig >>= \cfg' -> inductionEngine GeneralInduction (tpMergeCfg cfg cfg') nm p (sInductionStrategy p mhs steps) -- | Internal, shouldn't be needed outside the library {-# MINIMAL sInductionStrategy #-} sInductionStrategy :: (Proposition a, Zero m, SymVal t, EqSymbolic (SBV t)) => a -> (MeasureArgs a m, [ProofObj]) -> (Proof a -> StepArgs a t) -> Symbolic InductionStrategy -- | Do an inductive proof, based on the given strategy -inductionEngine :: Proposition a => InductionStyle -> Bool -> SMTConfig -> String -> a -> Symbolic InductionStrategy -> TP (Proof a) -inductionEngine style tagTheorem cfg nm result getStrategy = do +inductionEngine :: Proposition a => InductionStyle -> SMTConfig -> String -> a -> Symbolic InductionStrategy -> TP (Proof a) +inductionEngine style cfg nm result getStrategy = do cached <- lookupProofCache result case cached of Just prf -> returnCachedProof cfg nm prf @@ -603,7 +613,10 @@ RegularInduction -> "" GeneralInduction -> " (strong)" - message cfg $ "Inductive " ++ (if tagTheorem then "theorem" else "lemma") ++ qual ++ ": " ++ nm ++ "\n" + let header = "Inductive lemma" ++ qual ++ ": " ++ nm + message cfg $ header ++ "\n" + liftIO $ do isDry <- readIORef (dryRun tpSt) + when isDry $ modifyIORef' (maxRibbon tpSt) (max (length header)) strategy@InductionStrategy { inductionIntros , inductionMeasure @@ -623,8 +636,8 @@ query $ do case inductionMeasure of - Nothing -> queryDebug [nm ++ ": Induction" ++ qual ++ ", there is no custom measure to show non-negativeness."] - Just (m, hs) -> do queryDebug [nm ++ ": Induction, proving measure is always non-negative:"] + Nothing -> queryDebug [T.pack nm <> ": Induction" <> T.pack qual <> ", there is no custom measure to show non-negativeness."] + Just (m, hs) -> do queryDebug [T.pack nm <> ": Induction, proving measure is always non-negative:"] smtProofStep cfg tpSt "Step" 1 (TPProofStep False nm [] ["Measure is non-negative"]) (Just (sAnd (inductionIntros : map getObjProof hs))) @@ -632,8 +645,8 @@ [] (\d -> finishTP cfg "Q.E.D." d []) case inductionBaseCase of - Nothing -> queryDebug [nm ++ ": Induction" ++ qual ++ ", there is no base case to prove."] - Just bc -> do queryDebug [nm ++ ": Induction, proving base case:"] + Nothing -> queryDebug [T.pack nm <> ": Induction" <> T.pack qual <> ", there is no base case to prove."] + Just bc -> do queryDebug [T.pack nm <> ": Induction, proving base case:"] smtProofStep cfg tpSt "Step" 1 (TPProofStep False nm [] ["Base"]) (Just inductionIntros) @@ -1551,16 +1564,16 @@ pure r else do let new = cfg{tpOptions = (tpOptions cfg) {quiet = True}} restoring new topCfg $ do - r@Proof{proofOf = po@ProofObj{dependencies, aliases = aka, wasCached = cached}} <- prf + res <- tryTP prf cleanup - let nm = proofName po - akaStr | null aka = "" - | True = " (a.k.a. " ++ intercalate ", " aka ++ ")" - what | cached = "Cached" - | True = "Lemma" - tab <- liftIO $ startTP cfg (verbose cfg) what 0 (TPProofOneShot nm []) - liftIO $ finishTP cfg ("Q.E.D." ++ concludeModulo dependencies ++ akaStr) (tab, Nothing) [] - pure r + case res of + Left (_ :: SomeException) -> + -- Re-run with original config so failure details are visible + restoring cfg topCfg prf >> pure (error "unreachable") + Right r@Proof{proofOf = po@ProofObj{dependencies, aliases = aka, wasCached = cached}} -> do + let nm = proofName po + liftIO $ printLemmaResult cfg (verbose cfg) nm dependencies cached aka + pure r where restoring new old act = do setTPConfig new res <- act setTPConfig old diff --git a/Data/SBV/TP/Utils.hs b/Data/SBV/TP/Utils.hs --- a/Data/SBV/TP/Utils.hs +++ b/Data/SBV/TP/Utils.hs @@ -23,17 +23,18 @@ {-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.TP.Utils ( - TP, runTP, runTPWith, Proof(..), ProofObj(..), assumptionFromProof, sorry, quickCheckProof, noTermCheckProof + TP, runTP, runTPWith, tryTP, whenDryRun, unlessDryRun, Proof(..), ProofObj(..), assumptionFromProof, sorry, quickCheckProof, noTermCheckProof , startTP, finishTP, getTPState, getTPConfig, setTPConfig, tpGetNextUnique, TPState(..), TPStats(..), RootOfTrust(..) - , TPProofContext(..), message, updStats, rootOfTrust, concludeModulo + , TPProofContext(..), message, updStats, rootOfTrust, concludeModulo, printLemmaResult , ProofTree(..), TPUnique(..), showProofTree, showProofTreeHTML , addToProofCache, lookupProofCache, returnCachedProof - , tpQuiet, tpRibbon, tpAsms, tpStats + , tpQuiet, tpAsms, tpStats , measureLemma, measureLemmaWith ) where -import Control.Monad (unless) -import Control.Monad.Reader (ReaderT, runReaderT, MonadReader, ask, liftIO) +import Control.Exception (Exception, try) +import Control.Monad (unless, when) +import Control.Monad.Reader (ReaderT(..), runReaderT, MonadReader, ask, liftIO) import Control.Monad.Trans (MonadIO) import Data.Generics (everywhere, mkT) @@ -70,7 +71,6 @@ import Data.Dynamic import qualified Data.Map.Strict as Map -import Data.Map (Map) import qualified Data.Set as Set import Data.Set (Set) @@ -83,18 +83,37 @@ -- | Extra state we carry in a TP context data TPState = TPState { stats :: IORef TPStats - , proofCache :: IORef (Map (PropFingerprint, TypeRep) [ProofObj]) + , proofCache :: IORef (Map.Map (PropFingerprint, TypeRep) [ProofObj]) , config :: IORef SMTConfig , inRecallContext :: IORef Int , measuresVerified :: IORef (Set String) , productiveVerified :: IORef (Set String) , measuresEncountered :: IORef (Set String) + , dryRun :: IORef Bool -- ^ If True, collecting ribbon widths (no proving) + , maxRibbon :: IORef Int -- ^ Session-wide maximum ribbon length } -- | Monad for running TP proofs in. newtype TP a = TP (ReaderT TPState IO a) deriving newtype (Applicative, Functor, Monad, MonadIO, MonadReader TPState, MonadFail) +-- | Run a TP action, catching exceptions. +tryTP :: Exception e => TP a -> TP (Either e a) +tryTP (TP act) = TP $ ReaderT $ \st -> try (runReaderT act st) + +-- | Run an action only during the dry-run pass. +whenDryRun :: TP () -> TP () +whenDryRun act = do st <- ask + isDry <- liftIO $ readIORef (dryRun st) + when isDry act + +-- | Run an action only during the real (non-dry-run) pass. Useful for guarding user-facing output +-- (e.g., proof tree printing) that should be suppressed during ribbon calculation. +unlessDryRun :: TP () -> TP () +unlessDryRun act = do st <- ask + isDry <- liftIO $ readIORef (dryRun st) + unless isDry act + -- | Extract the integer node ID from an SV. svIntId :: SV -> Int svIntId (SV _ (NodeId (_, _, i))) = i @@ -163,12 +182,9 @@ -- | Return a cached proof, printing a brief "Q.E.D." line with optional "a.k.a." annotation. returnCachedProof :: SMTConfig -> String -> ProofObj -> TP (Proof a) returnCachedProof cfg nm prf = do - let aka = filter (/= nm) $ nub $ proofName prf : aliases prf - prf' = prf { proofName = nm, wasCached = True, aliases = aka } - akaStr | null aka = "" - | True = " (a.k.a. " ++ intercalate ", " aka ++ ")" - tab <- liftIO $ startTP cfg False "Cached" 0 (TPProofOneShot nm []) - liftIO $ finishTP cfg ("Q.E.D." ++ concludeModulo (dependencies prf) ++ akaStr) (tab, Nothing) [] + let aka = filter (/= nm) $ nub $ proofName prf : aliases prf + prf' = prf { proofName = nm, wasCached = True, aliases = aka } + liftIO $ printLemmaResult cfg False nm (dependencies prf) True aka pure $ Proof prf' -- | The context in which we make a check-sat call @@ -186,29 +202,48 @@ -- | Run a TP proof, using the given configuration. runTPWith :: SMTConfig -> TP a -> IO a runTPWith cfg@SMTConfig{tpOptions = TPOptions{printStats}} (TP f) = do - rStats <- newIORef $ TPStats { noOfCheckSats = 0, solverElapsed = 0, qcElapsed = 0 } - rCache <- newIORef Map.empty - rCfg <- newIORef cfg - rRecall <- newIORef (0 :: Int) - rMeasures <- newIORef Set.empty - rProductive <- newIORef Set.empty - rEncountered <- newIORef Set.empty - (mbT, r) <- timeIf printStats $ runReaderT f TPState { config = rCfg - , stats = rStats - , proofCache = rCache - , inRecallContext = rRecall - , measuresVerified = rMeasures - , productiveVerified = rProductive - , measuresEncountered = rEncountered - } + rDryRun <- newIORef True + rMaxRibbon <- newIORef 0 + let runPass c = do + rStats <- newIORef $ TPStats { noOfCheckSats = 0, solverElapsed = 0, qcElapsed = 0 } + rCache <- newIORef Map.empty + rCfg <- newIORef c + rRecall <- newIORef (0 :: Int) + rMeasures <- newIORef Set.empty + rProductive <- newIORef Set.empty + rEncountered <- newIORef Set.empty + let st = TPState { config = rCfg + , stats = rStats + , proofCache = rCache + , inRecallContext = rRecall + , measuresVerified = rMeasures + , productiveVerified = rProductive + , measuresEncountered = rEncountered + , dryRun = rDryRun + , maxRibbon = rMaxRibbon + } + a <- runReaderT f st + pure (a, st) + + -- Pass 1: Dry run to collect ribbon widths + _ <- runPass ((tpQuiet True cfg){verbose = False}) + + -- Pass 2: Real run with computed ribbon + writeIORef rDryRun False + ribbon <- readIORef rMaxRibbon + let cfg' = cfg{tpOptions = (tpOptions cfg) { ribbonLength = max 20 (ribbon + 4) }} + + (mbT, (r, TPState{stats = rStats, measuresVerified = rMeasures, productiveVerified = rProductive, measuresEncountered = rEncountered})) + <- timeIf printStats $ runPass cfg' + -- Print verified measures and productive functions verified <- readIORef rMeasures productive <- readIORef rProductive encountered <- readIORef rEncountered - unless (Set.null verified) $ printMeasures cfg (Set.toAscList verified) - unless (Set.null productive) $ printProductive cfg (Set.toAscList productive) + unless (Set.null verified) $ printMeasures cfg' (Set.toAscList verified) + unless (Set.null productive) $ printProductive cfg' (Set.toAscList productive) -- Belt-and-suspenders: make sure all encountered measures have been verified. -- Exclude functions in measuresBeingVerified: those are being verified by an outer caller @@ -231,7 +266,7 @@ , ("Decisions", show noOfCheckSats) ] - message cfg $ '[' : intercalate ", " [k ++ ": " ++ v | (k, v) <- stats] ++ "]\n" + message cfg' $ '[' : intercalate ", " [k ++ ": " ++ v | (k, v) <- stats] ++ "]\n" pure r -- | get the state @@ -264,7 +299,7 @@ | Just f <- redirectVerbose = liftIO $ appendFile f s | True - = liftIO $ putStr s + = liftIO $ putStr s >> hFlush stdout -- | Print the list of functions whose termination measures have been verified. printMeasures :: SMTConfig -> [String] -> IO () @@ -303,7 +338,7 @@ startTP :: SMTConfig -> Bool -> String -> Int -> TPProofContext -> IO Int startTP cfg newLine what level ctx = do message cfg $ line ++ if newLine then "\n" else "" hFlush stdout - return (length line) + pure (length line) where nm = case ctx of TPProofOneShot n _ -> n TPProofStep _ _ hs ss -> intercalate "." ss ++ userHints hs @@ -596,6 +631,16 @@ | any (\o -> uniqId o == TPSorry) ps = [sorry] | True = ps +-- | Print a one-line lemma result: @Lemma: name Q.E.D. [Modulo: ...] [Cached] (a.k.a. ...)@ +printLemmaResult :: SMTConfig -> Bool -> String -> [ProofObj] -> Bool -> [String] -> IO () +printLemmaResult cfg verboseFlag nm deps cached aka = do + tab <- startTP cfg verboseFlag "Lemma" 0 (TPProofOneShot nm []) + finishTP cfg ("Q.E.D." ++ concludeModulo deps ++ cacheStr ++ akaStr) (tab, Nothing) [] + where cacheStr | cached = " [Cached]" + | True = "" + akaStr | null aka = "" + | True = " (a.k.a. " ++ intercalate ", " aka ++ ")" + -- | Calculate the modulo string for dependencies concludeModulo :: [ProofObj] -> String concludeModulo by = case foldMap (rootOfTrust . Proof) by of @@ -607,12 +652,6 @@ -- will inherit the quiet settings from the surrounding environment. tpQuiet :: Bool -> SMTConfig -> SMTConfig tpQuiet b cfg = cfg{tpOptions = (tpOptions cfg) { quiet = b }} - --- | Change the size of the ribbon for TP proofs. Note that this setting will be effective with the --- call to 'runTP'\/'runTPWith', i.e., if you change the solver in a call to 'Data.SBV.TP.lemmaWith'\/'Data.SBV.TP.theoremWith', we --- will inherit the ribbon settings from the surrounding environment. -tpRibbon :: Int -> SMTConfig -> SMTConfig -tpRibbon i cfg = cfg{tpOptions = (tpOptions cfg) { ribbonLength = i }} -- | Make TP proofs produce statistics. Note that this setting will be effective with the -- call to 'runTP'\/'runTPWith', i.e., if you change the solver in a call to 'Data.SBV.TP.lemmaWith'\/'Data.SBV.TP.theoremWith', we diff --git a/Data/SBV/Tools/BMC.hs b/Data/SBV/Tools/BMC.hs --- a/Data/SBV/Tools/BMC.hs +++ b/Data/SBV/Tools/BMC.hs @@ -34,7 +34,7 @@ bmcRefute :: (Queriable IO st, res ~ QueryResult st) => Maybe Int -- ^ Optional bound -> Bool -- ^ Verbose: prints iteration count - -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.) + -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate. @@ -46,7 +46,7 @@ => SMTConfig -- ^ Solver to use -> Maybe Int -- ^ Optional bound -> Bool -- ^ Verbose: prints iteration count - -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.) + -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate. @@ -59,7 +59,7 @@ bmcCover :: (Queriable IO st, res ~ QueryResult st) => Maybe Int -- ^ Optional bound -> Bool -- ^ Verbose: prints iteration count - -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.) + -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate. @@ -71,7 +71,7 @@ => SMTConfig -- ^ Solver to use -> Maybe Int -- ^ Optional bound -> Bool -- ^ Verbose: prints iteration count - -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.) + -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> (st -> SBool) -- ^ Goal to cover, i.e., we find a set of transitions that satisfy this predicate. @@ -93,7 +93,7 @@ go i _ _ | Just l <- mbLimit, i >= l - = return $ Left $ what ++ " limit of " ++ show l ++ " reached. " ++ badResult + = pure $ Left $ what ++ " limit of " ++ show l ++ " reached. " ++ badResult go i curState sofar = do when chatty $ io $ putStrLn $ what ++ ": Iteration: " ++ show i @@ -110,9 +110,9 @@ DSat{} -> error $ what ++ ": Solver returned an unexpected delta-sat result." Sat -> do when chatty $ io $ putStrLn $ what ++ ": " ++ goodResult ++ " state found at iteration " ++ show i ms <- mapM project (curState : sofar) - return $ Right (i, reverse ms) + pure $ Right (i, reverse ms) Unk -> do when chatty $ io $ putStrLn $ what ++ ": Backend solver said unknown at iteration " ++ show i - return $ Left $ what ++ ": Solver said unknown in iteration " ++ show i + pure $ Left $ what ++ ": Solver said unknown in iteration " ++ show i Unsat -> do pop 1 nextState <- create constrain $ curState `trans` nextState diff --git a/Data/SBV/Tools/BVOptimize.hs b/Data/SBV/Tools/BVOptimize.hs --- a/Data/SBV/Tools/BVOptimize.hs +++ b/Data/SBV/Tools/BVOptimize.hs @@ -120,7 +120,7 @@ else constrain $ sNot b r <- checkSat case r of - Sat -> go bs >>= \res -> pop 1 >> return res + Sat -> go bs >>= \res -> pop 1 >> pure res Unsat -> pop 1 >> go bs Unk -> pop 1 >> rUnk DSat{} -> error "minMaxBV: Unexpected DSat result" diff --git a/Data/SBV/Tools/GenTest.hs b/Data/SBV/Tools/GenTest.hs --- a/Data/SBV/Tools/GenTest.hs +++ b/Data/SBV/Tools/GenTest.hs @@ -9,7 +9,7 @@ -- Test generation from symbolic programs ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Tools.GenTest ( -- * Test case generation @@ -49,7 +49,7 @@ genTest :: Outputtable a => Int -> Symbolic a -> IO TestVectors genTest n m = gen 0 [] where gen i sofar - | i == n = return $ TV $ reverse sofar + | i == n = pure $ TV $ reverse sofar | True = do t <- tc gen (i+1) (t:sofar) tc = do (_, Result {resTraces=tvals, resConsts=(_, cs), resDefinitions=definitions, resConstraints=cstrs, resOutputs=os}) <- runSymbolic defaultSMTCfg (Concrete Nothing) (m >>= output) @@ -57,7 +57,7 @@ cond = and [cvToBool (cval v) | (False, _, v) <- F.toList cstrs] -- Only pick-up "hard" constraints, as indicated by False in the fist component unless (null definitions) $ error "Cannot generate tests in the presence of 'smtFunction' calls!" if cond - then return (map snd tvals, map cval os) + then pure (map snd tvals, map cval os) else tc -- try again, with the same set of constraints -- | Test output style @@ -95,8 +95,7 @@ | needsWord = ["import Data.Word", ""] | needsRatio = ["import Data.Ratio"] | True = [] - where ((is, os):_) = vs - params = is ++ os + where params = case vs of { (is, os):_ -> is ++ os; _ -> error "SBV.renderTest: impossible, empty test vectors" } needsInt = any isSW params needsWord = any isUW params needsRatio = any isR params @@ -109,7 +108,9 @@ isUW cv = case kindOf cv of KBounded False sz -> sz > 1 _ -> False - modName = let (f:r) = n in toUpper f : r + modName = case n of + f:r -> toUpper f : r + _ -> error "SBV.renderTest: impossible, empty module name" pad = replicate (length n + 3) ' ' getType [] = "[a]" getType ((i, o):_) = "[(" ++ mapType typeOf i ++ ", " ++ mapType typeOf o ++ ")]" @@ -147,21 +148,22 @@ s cv = case kindOf cv of KVar{} -> error $ "SBV.renderTest: Unexpected: " ++ show (kindOf cv) KBool -> take 5 (show (cvToBool cv) ++ repeat ' ') - KBounded sgn sz -> let CInteger w = cvVal cv in T.unpack $ shex False True (sgn, sz) w - KUnbounded -> let CInteger w = cvVal cv in T.unpack $ shexI False True w - KFloat -> let CFloat w = cvVal cv in showHFloat w - KDouble -> let CDouble w = cvVal cv in showHDouble w + KBounded sgn sz -> case cvVal cv of { CInteger w -> T.unpack $ shex False True (sgn, sz) w; r -> bad r } + KUnbounded -> case cvVal cv of { CInteger w -> T.unpack $ shexI False True w; r -> bad r } + KFloat -> case cvVal cv of { CFloat w -> showHFloat w; r -> bad r } + KDouble -> case cvVal cv of { CDouble w -> showHDouble w; r -> bad r } KRational -> error "SBV.renderTest: Unsupported rational number" KFP{} -> error "SBV.renderTest: Unsupported arbitrary float" KChar -> error "SBV.renderTest: Unsupported char" KString -> error "SBV.renderTest: Unsupported string" - KReal -> let CAlgReal w = cvVal cv in algRealToHaskell w + KReal -> case cvVal cv of { CAlgReal w -> algRealToHaskell w; r -> bad r } KList es -> error $ "SBV.renderTest: Unsupported list valued sort: [" ++ show es ++ "]" KSet es -> error $ "SBV.renderTest: Unsupported set valued sort: {" ++ show es ++ "}" k@KApp{} -> error $ "SBV.renderTest: Unsupported adt app: " ++ show k k@KADT{} -> error $ "SBV.renderTest: Unsupported adt: " ++ show k k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple: " ++ show k k@KArray{} -> error $ "SBV.renderTest: Unsupported array: " ++ show k + where bad _ = error $ "SBV.renderTest: Unexpected CVal for kind: " ++ show (kindOf cv) c :: String -> [([CV], [CV])] -> String c n vs = intercalate "\n" $ @@ -262,10 +264,10 @@ v cv = case kindOf cv of KVar{} -> error $ "SBV.renderTest: Unexpected: " ++ show (kindOf cv) KBool -> if cvToBool cv then "true " else "false" - KBounded sgn sz -> let CInteger w = cvVal cv in T.unpack $ chex False True (sgn, sz) w - KUnbounded -> let CInteger w = cvVal cv in T.unpack $ shexI False True w - KFloat -> let CFloat w = cvVal cv in showCFloat w - KDouble -> let CDouble w = cvVal cv in showCDouble w + KBounded sgn sz -> case cvVal cv of { CInteger w -> T.unpack $ chex False True (sgn, sz) w; r -> bad r } + KUnbounded -> case cvVal cv of { CInteger w -> T.unpack $ shexI False True w; r -> bad r } + KFloat -> case cvVal cv of { CFloat w -> showCFloat w; r -> bad r } + KDouble -> case cvVal cv of { CDouble w -> showCDouble w; r -> bad r } KRational -> error "SBV.renderTest: Unsupported rational number" KFP{} -> error "SBV.renderTest: Unsupported arbitrary float" KChar -> error "SBV.renderTest: Unsupported char" @@ -277,6 +279,7 @@ k@KADT{} -> error $ "SBV.renderTest: Unsupported adt: " ++ show k k@KTuple{} -> error $ "SBV.renderTest: Unsupported tuple sort: " ++ show k k@KArray{} -> error $ "SBV.renderTest: Unsupported sum sort: " ++ show k + where bad _ = error $ "SBV.renderTest: Unexpected CVal for kind: " ++ show (kindOf cv) outLine | null vs = "printf(\"\");" @@ -375,9 +378,9 @@ form [] bs = error $ "SBV.renderTest: Mismatched index in stream, extra " ++ show (length bs) ++ " bit(s) remain." form (i:is) bs | length bs < i = error $ "SBV.renderTest: Mismatched index in stream, was looking for " ++ show i ++ " bit(s), but only " ++ show bs ++ " remains." - | i == 1 = let b:r = bs - v = if b == '1' then "T" else "F" - in v : form is r + | i == 1 = case bs of + b:r -> (if b == '1' then "T" else "F") : form is r + _ -> error "SBV.renderTest: impossible, empty bit stream" | True = let (f, r) = splitAt i bs v = "c \"" ++ show i ++ "'b" ++ f ++ "\"" in v : form is r diff --git a/Data/SBV/Tools/Induction.hs b/Data/SBV/Tools/Induction.hs --- a/Data/SBV/Tools/Induction.hs +++ b/Data/SBV/Tools/Induction.hs @@ -84,7 +84,7 @@ -- and "Documentation.SBV.Examples.ProofTools.Sum" for examples. induct :: (Show res, Queriable IO st, res ~ QueryResult st) => Bool -- ^ Verbose mode - -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @return ()@ if not needed.) + -> Symbolic () -- ^ Setup code, if necessary. (Typically used for 'Data.SBV.setOption' calls. Pass @pure ()@ if not needed.) -> (st -> SBool) -- ^ Initial condition -> (st -> st -> SBool) -- ^ Transition relation -> [(String, st -> SBool)] -- ^ Strengthenings, if any. The @String@ is a simple tag. @@ -115,14 +115,14 @@ $ try "Proving partial correctness" (\s _ -> let (term, result) = goal s in inv s .&& term .=> result) (Failed PartialCorrectness) - (msg "Done" >> return Proven) + (msg "Done" >> pure Proven) where msg = when chatty . putStrLn try m p wrap cont = do msg m res <- check p case res of - Just ex -> return $ wrap ex + Just ex -> pure $ wrap ex Nothing -> cont check p = runSMTWith cfg $ do @@ -135,14 +135,14 @@ case cs of Unk -> error "Solver said unknown" DSat{} -> error "Solver returned a delta-sat result" - Unsat -> return Nothing + Unsat -> pure Nothing Sat -> do io $ msg "Failed in state:" exS <- project s io $ msg $ show exS io $ msg "Transitioning to:" exS' <- project s' io $ msg $ show exS' - return $ Just (exS, exS') + pure $ Just (exS, exS') strengthen [] cont = cont strengthen ((nm, st):sts) cont = try ("Proving strengthening initiation : " ++ nm) diff --git a/Data/SBV/Tools/Range.hs b/Data/SBV/Tools/Range.hs --- a/Data/SBV/Tools/Range.hs +++ b/Data/SBV/Tools/Range.hs @@ -108,7 +108,7 @@ rangesWith :: forall a. (OrdSymbolic (SBV a), Num a, SymVal a, SatModel a, Metric a, SymVal (MetricSpace a), SatModel (MetricSpace a)) => SMTConfig -> (SBV a -> SBool) -> IO [Range a] rangesWith cfg prop = do mbBounds <- getInitialBounds case mbBounds of - Nothing -> return [] + Nothing -> pure [] Just r -> search [r] [] where getInitialBounds :: IO (Maybe (Range a)) @@ -155,16 +155,16 @@ constrain $ prop x cstr objName x case m of - Unsatisfiable{} -> return Nothing + Unsatisfiable{} -> pure Nothing Unknown{} -> error "Solver said Unknown!" ProofError{} -> error (show res) - _ -> return $ getModelObjectiveValue (annotateForMS (Proxy @a) objName) m + _ -> pure $ getModelObjectiveValue (annotateForMS (Proxy @a) objName) m mi <- getBound minimize ma <- getBound maximize case (mi, ma) of - (Just minV, Just maxV) -> return $ Just $ Range (getGenVal minV) (getGenVal maxV) - _ -> return Nothing + (Just minV, Just maxV) -> pure $ Just $ Range (getGenVal minV) (getGenVal maxV) + _ -> pure Nothing -- Is this range satisfiable? Returns a witness to it. witness :: Range a -> Symbolic (SBV a) @@ -180,17 +180,17 @@ constrain $ lower .&& upper - return x + pure x isFeasible :: Range a -> IO Bool isFeasible r = runSMTWith cfg $ do _ <- witness r query $ do cs <- checkSat case cs of - Unsat -> return False + Unsat -> pure False DSat{} -> error "Data.SBV.interval.isFeasible: Solver returned a delta-satisfiable result!" Unk -> error "Data.SBV.interval.isFeasible: Solver said unknown!" - Sat -> return True + Sat -> pure True bisect :: Range a -> IO (Maybe [Range a]) bisect r@(Range lo hi) = runSMTWith cfg $ do x <- witness r @@ -199,14 +199,14 @@ query $ do cs <- checkSat case cs of - Unsat -> return Nothing + Unsat -> pure Nothing DSat{} -> error "Data.SBV.interval.bisect: Solver returned a delta-satisfiable result!" Unk -> error "Data.SBV.interval.bisect: Solver said unknown!" Sat -> do midV <- Open <$> getValue x - return $ Just [Range lo midV, Range midV hi] + pure $ Just [Range lo midV, Range midV hi] search :: [Range a] -> [Range a] -> IO [Range a] - search [] sofar = return $ reverse sofar + search [] sofar = pure $ reverse sofar search (c:cs) sofar = do feasible <- isFeasible c if feasible then do mbCS <- bisect c diff --git a/Data/SBV/Tools/WeakestPreconditions.hs b/Data/SBV/Tools/WeakestPreconditions.hs --- a/Data/SBV/Tools/WeakestPreconditions.hs +++ b/Data/SBV/Tools/WeakestPreconditions.hs @@ -73,7 +73,7 @@ -- -- The 'setup' field is reserved for any symbolic code you might -- want to run before the proof takes place, typically for calls --- to 'Data.SBV.setOption'. If not needed, simply pass @return ()@. +-- to 'Data.SBV.setOption'. If not needed, simply pass @pure ()@. -- For an interesting use case where we use setup to axiomatize -- the spec, see "Documentation.SBV.Examples.WeakestPreconditions.Fib" -- and "Documentation.SBV.Examples.WeakestPreconditions.GCD". @@ -234,7 +234,7 @@ Sat -> do let checkVC :: (SBool, VC st SInteger) -> Query [VC res Integer] checkVC (cond, vc) = do c <- getValue cond if c - then return [] -- The VC was OK + then pure [] -- The VC was OK else do vc' <- case vc of BadPrecondition s -> BadPrecondition <$> project s BadPostcondition s1 s2 -> BadPostcondition <$> project s1 <*> project s2 @@ -244,13 +244,13 @@ InvariantMaintain l s1 s2 -> InvariantMaintain l <$> project s1 <*> project s2 MeasureBound l (s, m) -> do r <- project s v <- mapM getValue m - return $ MeasureBound l (r, v) + pure $ MeasureBound l (r, v) MeasureDecrease l (s1, i1) (s2, i2) -> do r1 <- project s1 v1 <- mapM getValue i1 r2 <- project s2 v2 <- mapM getValue i2 - return $ MeasureDecrease l (r1, v1) (r2, v2) - return [vc'] + pure $ MeasureDecrease l (r1, v1) (r2, v2) + pure [vc'] badVCs <- concat <$> mapM checkVC vcs @@ -267,7 +267,7 @@ let disp c = mapM_ msg [" " ++ l | l <- lines (show c)] mapM_ disp badVCs - return $ Failed badVCs + pure $ Failed badVCs msg = io . when wpVerbose . putStrLn @@ -275,28 +275,28 @@ wp :: st -> Stmt st -> (st -> [(SBool, VC st SInteger)]) -> Query (st -> [(SBool, VC st SInteger)]) -- Skip simply keeps the conditions - wp _ Skip post = return post + wp _ Skip post = pure post -- Abort is never satisfiable. The only way to have Abort's VC to pass is -- to run it in a precondition (either via program or in an if branch) that -- evaluates to false, i.e., it must not be reachable. - wp start (Abort nm) _ = return $ \st -> [(sFalse, AbortReachable nm start st)] + wp start (Abort nm) _ = pure $ \st -> [(sFalse, AbortReachable nm start st)] -- Assign simply transforms the state and passes on. It also checks that the -- stability constraints are not violated. - wp _ (Assign f) post = return $ \st -> let st' = f st - vcs = map (\s -> let (nm, b) = s st st' in (b, Unstable nm st st')) stability - in vcs ++ post st' + wp _ (Assign f) post = pure $ \st -> let st' = f st + vcs = map (\s -> let (nm, b) = s st st' in (b, Unstable nm st st')) stability + in vcs ++ post st' -- Conditional: We separately collect the VCs, and predicate with the proper branch condition wp start (If c tb fb) post = do tWP <- wp start tb post fWP <- wp start fb post - return $ \st -> let cond = c st - in [( cond .=> b, v) | (b, v) <- tWP st] - ++ [(sNot cond .=> b, v) | (b, v) <- fWP st] + pure $ \st -> let cond = c st + in [( cond .=> b, v) | (b, v) <- tWP st] + ++ [(sNot cond .=> b, v) | (b, v) <- fWP st] -- Sequencing: Simply run through the statements - wp _ (Seq []) post = return post + wp _ (Seq []) post = pure post wp start (Seq (s:ss)) post = wp start s =<< wp start (Seq ss) post -- While loop, where all the WP magic happens! @@ -323,20 +323,20 @@ -- Condition 4: If we iterate, measure must always be non-negative measureNonNegative <- if noMeasure - then return (const []) + then pure (const []) else wp st' Skip (const [(iterates .=> curM .>= zeroM, MeasureBound nm (st', curM))]) -- Condition 5: If we iterate, the measure must decrease measureDecreases <- if noMeasure - then return (const []) + then pure (const []) else wp st' body (\st -> let prevM = m st in [(iterates .=> prevM .< curM, MeasureDecrease nm (st', curM) (st, prevM))]) -- Simply concatenate the VCs from all our conditions: - return $ \st -> invHoldsPrior st - ++ invMaintained st' - ++ invEstablish st' - ++ measureNonNegative st' - ++ measureDecreases st' + pure $ \st -> invHoldsPrior st + ++ invMaintained st' + ++ invEstablish st' + ++ measureNonNegative st' + ++ measureDecreases st' -- | Check correctness using the default solver. Equivalent to @'wpProveWith' 'defaultWPCfg'@. wpProve :: (Show res, Mergeable st, Queriable IO st, res ~ QueryResult st) => Program st -> IO (ProofResult res) @@ -388,7 +388,7 @@ else giveUp start (BadPrecondition start) "*** Initial state does not satisfy the precondition:" case status of - s@Stuck{} -> return s + s@Stuck{} -> pure s Good end -> if unwrap [] "checking postcondition" (postcondition end) then step [] end "*** Program successfully terminated, post condition holds of the final state:" else giveUp end (BadPostcondition start end) "*** Failed, final state does not satisfy the postcondition:" @@ -403,16 +403,16 @@ step :: Loc -> st -> String -> IO (Status st) step l st m = do putStrLn $ sLoc l m printST st - return $ Good st + pure $ Good st stop :: Loc -> VC st Integer -> String -> IO (Status st) stop l vc m = do putStrLn $ sLoc l m - return $ Stuck vc + pure $ Stuck vc giveUp :: st -> VC st Integer -> String -> IO (Status st) giveUp st vc m = do r <- stop [] vc m printST st - return r + pure r dispST :: st -> String dispST st = intercalate "\n" [" " ++ l | l <- lines (show st)] @@ -434,7 +434,7 @@ ] go :: Loc -> Stmt st -> Status st -> IO (Status st) - go _ _ s@Stuck{} = return s + go _ _ s@Stuck{} = pure s go loc p (Good st) = analyze p where analyze Skip = step loc st "Skip" @@ -453,7 +453,7 @@ where branchTrue = unwrap loc "evaluating the test condition" (c st) analyze (Seq stmts) = walk stmts 1 (Good st) - where walk [] _ is = return is + where walk [] _ is = pure is walk (s:ss) c is = walk ss (c+1) =<< go (Line c : loc) s is analyze (While loopName invariant mbMeasure condition body) @@ -470,7 +470,7 @@ currentMeasure = map (unwrap loc (tag "evaluating the measure")) . measure currentInvariant = unwrap loc (tag "evaluating the invariant") . invariant - while _ _ _ s@Stuck{} = return s + while _ _ _ s@Stuck{} = pure s while c prevST mbPrev (Good is) | not (currentCondition is) = step loc is $ tag "condition fails, terminating" diff --git a/Data/SBV/Tuple.hs b/Data/SBV/Tuple.hs --- a/Data/SBV/Tuple.hs +++ b/Data/SBV/Tuple.hs @@ -18,7 +18,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module Data.SBV.Tuple ( -- * Symbolic field access diff --git a/Data/SBV/Utils/CrackNum.hs b/Data/SBV/Utils/CrackNum.hs --- a/Data/SBV/Utils/CrackNum.hs +++ b/Data/SBV/Utils/CrackNum.hs @@ -11,7 +11,7 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Utils.CrackNum ( crackNum @@ -57,10 +57,17 @@ KArray {} -> Nothing -- Actual crackables - KFloat{} -> Just $ let CFloat f = cvVal cv in float verbose mbIV f - KDouble{} -> Just $ let CDouble d = cvVal cv in float verbose mbIV d - KFP{} -> Just $ let CFP f = cvVal cv in float verbose mbIV f - KBounded sg sz -> Just $ let CInteger i = cvVal cv in int sg sz i + KFloat{} | CFloat f <- cvVal cv -> Just $ float verbose mbIV f + | True -> Nothing -- Can't really happen; but don't die + + KDouble{} | CDouble d <- cvVal cv -> Just $ float verbose mbIV d + | True -> Nothing -- Can't really happen; but don't die + + KFP{} | CFP f <- cvVal cv -> Just $ float verbose mbIV f + | True -> Nothing -- Can't really happen; but don't die + + KBounded sg sz | CInteger i <- cvVal cv -> Just $ int sg sz i + | True -> Nothing -- Can't really happen; but don't die -- How far off the screen we want displayed? Somewhat experimentally found. tab :: String diff --git a/Data/SBV/Utils/Lib.hs b/Data/SBV/Utils/Lib.hs --- a/Data/SBV/Utils/Lib.hs +++ b/Data/SBV/Utils/Lib.hs @@ -17,22 +17,30 @@ module Data.SBV.Utils.Lib ( mlift2, mlift3, mlift4, mlift5, mlift6, mlift7, mlift8 , joinArgs, splitArgs , stringToQFS, qfsToString + , showText , isKString , checkObservableName - , needsBars, barify, isEnclosedInBars - , noSurrounding, unQuote, unBar, nameSupply + , needsBars, barify + , unQuote, unBar, nameSupply , atProxy + , mapToSortedList , curry2, curry3, curry4, curry5, curry6, curry7, curry8, curry9, curry10, curry11, curry12 , uncurry2, uncurry3, uncurry4, uncurry5, uncurry6, uncurry7, uncurry8, uncurry9, uncurry10, uncurry11, uncurry12 ) where import Data.Char (isSpace, chr, ord, isDigit, isAscii, isAlphaNum) -import Data.List (isPrefixOf, isSuffixOf) +import Data.List (isPrefixOf, isSuffixOf, sortBy) +import Data.Ord (comparing) import Data.Dynamic (fromDynamic, toDyn, Typeable) import Data.Maybe (fromJust, isJust, isNothing) import Data.Proxy +import Data.Text (Text) +import qualified Data.Text as T + +import qualified Data.Map.Strict as Map + import Type.Reflection (typeRep) import Numeric (readHex, showHex) @@ -46,31 +54,31 @@ -- | Monadic lift over 2-tuples mlift2 :: Monad m => (a' -> b' -> r) -> (a -> m a') -> (b -> m b') -> (a, b) -> m r -mlift2 k f g (a, b) = f a >>= \a' -> g b >>= \b' -> return $ k a' b' +mlift2 k f g (a, b) = f a >>= \a' -> g b >>= \b' -> pure $ k a' b' -- | Monadic lift over 3-tuples mlift3 :: Monad m => (a' -> b' -> c' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (a, b, c) -> m r -mlift3 k f g h (a, b, c) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> return $ k a' b' c' +mlift3 k f g h (a, b, c) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> pure $ k a' b' c' -- | Monadic lift over 4-tuples mlift4 :: Monad m => (a' -> b' -> c' -> d' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (a, b, c, d) -> m r -mlift4 k f g h i (a, b, c, d) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> return $ k a' b' c' d' +mlift4 k f g h i (a, b, c, d) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> pure $ k a' b' c' d' -- | Monadic lift over 5-tuples mlift5 :: Monad m => (a' -> b' -> c' -> d' -> e' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (a, b, c, d, e) -> m r -mlift5 k f g h i j (a, b, c, d, e) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> return $ k a' b' c' d' e' +mlift5 k f g h i j (a, b, c, d, e) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> pure $ k a' b' c' d' e' -- | Monadic lift over 6-tuples mlift6 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (a, b, c, d, e, f) -> m r -mlift6 k f g h i j l (a, b, c, d, e, y) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> return $ k a' b' c' d' e' y' +mlift6 k f g h i j l (a, b, c, d, e, y) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> pure $ k a' b' c' d' e' y' -- | Monadic lift over 7-tuples mlift7 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> g' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (g -> m g') -> (a, b, c, d, e, f, g) -> m r -mlift7 k f g h i j l m (a, b, c, d, e, y, z) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> return $ k a' b' c' d' e' y' z' +mlift7 k f g h i j l m (a, b, c, d, e, y, z) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> pure $ k a' b' c' d' e' y' z' -- | Monadic lift over 8-tuples mlift8 :: Monad m => (a' -> b' -> c' -> d' -> e' -> f' -> g' -> h' -> r) -> (a -> m a') -> (b -> m b') -> (c -> m c') -> (d -> m d') -> (e -> m e') -> (f -> m f') -> (g -> m g') -> (h -> m h') -> (a, b, c, d, e, f, g, h) -> m r -mlift8 k f g h i j l m n (a, b, c, d, e, y, z, w) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> n w >>= \w' -> return $ k a' b' c' d' e' y' z' w' +mlift8 k f g h i j l m n (a, b, c, d, e, y, z, w) = f a >>= \a' -> g b >>= \b' -> h c >>= \c' -> i d >>= \d' -> j e >>= \e' -> l y >>= \y' -> m z >>= \z' -> n w >>= \w' -> pure $ k a' b' c' d' e' y' z' w' -- Command line argument parsing code courtesy of Neil Mitchell's cmdargs package: see -- @@ -134,6 +142,10 @@ -- Otherwise, just proceed; hopefully we covered everything above go (c : rest) = c : go rest +-- | Show a value as 'Text'. +showText :: Show a => a -> Text +showText = T.pack . show + -- | Given a Haskell string, convert it to SMTLib. if ord is 0x00020 to 0x0007E, then we print it as is -- to cover the printable ASCII range. stringToQFS :: String -> String @@ -272,3 +284,9 @@ uncurry12 :: (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k -> l -> z) -> (a, b, c, d, e, f, g, h, i, j, k, l) -> z uncurry12 fn (a, b, c, d, e, f, g, h, i, j, k, l) = fn a b c d e f g h i j k l + +-- | Convert a map to a list of @(value, key)@ pairs, sorted by value. +-- Useful when the map is keyed by a descriptor but indexed by an integer +-- that determines output order. +mapToSortedList :: Ord v => Map.Map k v -> [(v, k)] +mapToSortedList = sortBy (comparing fst) . map (\(a, b) -> (b, a)) . Map.toList diff --git a/Data/SBV/Utils/Numeric.hs b/Data/SBV/Utils/Numeric.hs --- a/Data/SBV/Utils/Numeric.hs +++ b/Data/SBV/Utils/Numeric.hs @@ -9,7 +9,8 @@ -- Various number related utilities ----------------------------------------------------------------------------- -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -20,6 +21,7 @@ ) where import Data.Word +import Data.Text (Text) import Data.Array.ST (newArray, readArray, MArray, STUArray) import Data.Array.Unsafe (castSTUArray) import GHC.ST (runST, ST) @@ -72,7 +74,7 @@ | isInfinite x || isNaN x = 0 / 0 | y == 0 || isNaN y = 0 / 0 | isInfinite y = x - | True = pSign (x - fromRational (fromInteger d * ry)) + | True = pSign (fromRational (rx - fromInteger d * ry)) where rx, ry, rd :: Rational rx = toRational x ry = toRational y @@ -176,7 +178,7 @@ arbitrary = elements [minBound .. maxBound] -- | Convert a rounding mode to the format SMT-Lib2 understands. -smtRoundingMode :: RoundingMode -> String +smtRoundingMode :: RoundingMode -> Text smtRoundingMode RoundNearestTiesToEven = "roundNearestTiesToEven" smtRoundingMode RoundNearestTiesToAway = "roundNearestTiesToAway" smtRoundingMode RoundTowardPositive = "roundTowardPositive" diff --git a/Data/SBV/Utils/PrettyNum.hs b/Data/SBV/Utils/PrettyNum.hs --- a/Data/SBV/Utils/PrettyNum.hs +++ b/Data/SBV/Utils/PrettyNum.hs @@ -10,9 +10,10 @@ ----------------------------------------------------------------------------- {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wall -Werror #-} module Data.SBV.Utils.PrettyNum ( PrettyNum(..), readBin, shex, chex, shexI, sbin, sbinI @@ -21,7 +22,7 @@ , showNegativeNumber ) where -import Data.Bits ((.&.), countTrailingZeros) +import Data.Bits ((.&.), countTrailingZeros, testBit) import Data.Char (intToDigit, ord, chr) import Data.Int (Int8, Int16, Int32, Int64) import Data.List (isPrefixOf) @@ -42,8 +43,8 @@ import Data.SBV.Core.AlgReals (algRealToSMTLib2) import Data.SBV.Core.SizedFloats (fprToSMTLib2, bfToString) -import Data.SBV.Utils.Lib (stringToQFS) -import Data.SBV.Utils.Numeric (smtRoundingMode) +import Data.SBV.Utils.Lib (stringToQFS, showText) +import Data.SBV.Utils.Numeric (smtRoundingMode, floatToWord, doubleToWord) -- | PrettyNum class captures printing of numbers in hex and binary formats; also supporting negative numbers. class PrettyNum a where @@ -62,20 +63,20 @@ -- Why not default methods? Because defaults need "Integral a" but Bool is not.. instance PrettyNum Bool where - hexS = T.pack . show - binS = T.pack . show - hexP = T.pack . show - binP = T.pack . show - hex = T.pack . show - bin = T.pack . show + hexS = showText + binS = showText + hexP = showText + binP = showText + hex = showText + bin = showText instance PrettyNum String where - hexS = T.pack . show - binS = T.pack . show - hexP = T.pack . show - binP = T.pack . show - hex = T.pack . show - bin = T.pack . show + hexS = showText + binS = showText + hexP = showText + binP = showText + hex = showText + bin = showText instance PrettyNum Word8 where hexS = shex True True (False, 8) @@ -168,78 +169,49 @@ bin = sbinI False False shBKind :: HasKind a => a -> Text -shBKind a = T.pack " :: " <> showBaseKind (kindOf a) +shBKind a = " :: " <> showBaseKind (kindOf a) instance PrettyNum CV where - hexS cv | isADT cv = T.pack (show cv) <> shBKind cv - | isBoolean cv = hexS (cvToBool cv) <> shBKind cv - | isFloat cv = let CFloat f = cvVal cv in T.pack (N.showHFloat f "") <> shBKind cv - | isDouble cv = let CDouble d = cvVal cv in T.pack (N.showHFloat d "") <> shBKind cv - | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 16 True True f) <> shBKind cv - | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r) <> shBKind cv - | isString cv = let CString s = cvVal cv in T.pack (show s) <> shBKind cv - | not (isBounded cv) = let CInteger i = cvVal cv in shexI True True i - | True = let CInteger i = cvVal cv in shex True True (hasSign cv, intSizeOf cv) i - - binS cv | isADT cv = T.pack (show cv) <> shBKind cv - | isBoolean cv = binS (cvToBool cv) <> shBKind cv - | isFloat cv = let CFloat f = cvVal cv in T.pack (showBFloat f "") <> shBKind cv - | isDouble cv = let CDouble d = cvVal cv in T.pack (showBFloat d "") <> shBKind cv - | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 2 True True f) <> shBKind cv - | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r) <> shBKind cv - | isString cv = let CString s = cvVal cv in T.pack (show s) <> shBKind cv - | not (isBounded cv) = let CInteger i = cvVal cv in sbinI True True i - | True = let CInteger i = cvVal cv in sbin True True (hasSign cv, intSizeOf cv) i - - hexP cv | isADT cv = T.pack (show cv) - | isBoolean cv = hexS (cvToBool cv) - | isFloat cv = let CFloat f = cvVal cv in T.pack (show f) - | isDouble cv = let CDouble d = cvVal cv in T.pack (show d) - | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 16 True True f) - | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r) - | isString cv = let CString s = cvVal cv in T.pack (show s) - | not (isBounded cv) = let CInteger i = cvVal cv in shexI False True i - | True = let CInteger i = cvVal cv in shex False True (hasSign cv, intSizeOf cv) i - - binP cv | isADT cv = T.pack (show cv) - | isBoolean cv = binS (cvToBool cv) - | isFloat cv = let CFloat f = cvVal cv in T.pack (show f) - | isDouble cv = let CDouble d = cvVal cv in T.pack (show d) - | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 2 True True f) - | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r) - | isString cv = let CString s = cvVal cv in T.pack (show s) - | not (isBounded cv) = let CInteger i = cvVal cv in sbinI False True i - | True = let CInteger i = cvVal cv in sbin False True (hasSign cv, intSizeOf cv) i - - hex cv | isADT cv = T.pack (show cv) - | isBoolean cv = hexS (cvToBool cv) - | isFloat cv = let CFloat f = cvVal cv in T.pack (show f) - | isDouble cv = let CDouble d = cvVal cv in T.pack (show d) - | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 16 False True f) - | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r) - | isString cv = let CString s = cvVal cv in T.pack (show s) - | not (isBounded cv) = let CInteger i = cvVal cv in shexI False False i - | True = let CInteger i = cvVal cv in shex False False (hasSign cv, intSizeOf cv) i + hexS = cvPretty True True True True (\f -> T.pack (N.showHFloat f "")) (\d -> T.pack (N.showHFloat d "")) + binS = cvPretty False True True True (\f -> T.pack (showBFloat f "")) (\d -> T.pack (showBFloat d "")) + hexP = cvPretty True False True False showText showText + binP = cvPretty False False True False showText showText + hex = cvPretty True False False False showText showText + bin = cvPretty False False False False showText showText - bin cv | isADT cv = T.pack (show cv) - | isBoolean cv = binS (cvToBool cv) - | isFloat cv = let CFloat f = cvVal cv in T.pack (show f) - | isDouble cv = let CDouble d = cvVal cv in T.pack (show d) - | isFP cv = let CFP f = cvVal cv in T.pack (bfToString 2 False True f) - | isReal cv = let CAlgReal r = cvVal cv in T.pack (show r) - | isString cv = let CString s = cvVal cv in T.pack (show s) - | not (isBounded cv) = let CInteger i = cvVal cv in sbinI False False i - | True = let CInteger i = cvVal cv in sbin False False (hasSign cv, intSizeOf cv) i +-- | Factor out the common structure of PrettyNum CV methods +cvPretty :: Bool -- ^ isHex (True) or isBin (False) + -> Bool -- ^ Show type suffix on integers + -> Bool -- ^ Show prefix (0x/0b) on integers + -> Bool -- ^ Show kind suffix on non-integer cases + -> (Float -> Text) -- ^ Float formatter + -> (Double -> Text) -- ^ Double formatter + -> CV -> Text +cvPretty isHex shType shPre shKind fmtF fmtD cv + | isADT cv = showText cv <> knd + | isBoolean cv = (if isHex then hexS else binS) (cvToBool cv) <> knd + | isFloat cv, CFloat f <- cvVal cv = fmtF f <> knd + | isDouble cv, CDouble d <- cvVal cv = fmtD d <> knd + | isFP cv, CFP f <- cvVal cv = T.pack (bfToString base shPre True f) <> knd + | isReal cv, CAlgReal r <- cvVal cv = showText r <> knd + | isString cv, CString s <- cvVal cv = showText s <> knd + | not (isBounded cv), CInteger i <- cvVal cv = intI i + | CInteger i <- cvVal cv = intB (hasSign cv, intSizeOf cv) i + | True = error $ "PrettyNum: Received CV that can't be displayed: " ++ show cv + where knd = if shKind then shBKind cv else "" + base = if isHex then 16 else 2 + intI = (if isHex then shexI else sbinI) shType shPre + intB = (if isHex then shex else sbin) shType shPre instance (SymVal a, PrettyNum a) => PrettyNum (SBV a) where - hexS s = maybe (T.pack $ show s) (hexS :: a -> Text) $ unliteral s - binS s = maybe (T.pack $ show s) (binS :: a -> Text) $ unliteral s + hexS s = maybe (showText s) (hexS :: a -> Text) $ unliteral s + binS s = maybe (showText s) (binS :: a -> Text) $ unliteral s - hexP s = maybe (T.pack $ show s) (hexP :: a -> Text) $ unliteral s - binP s = maybe (T.pack $ show s) (binP :: a -> Text) $ unliteral s + hexP s = maybe (showText s) (hexP :: a -> Text) $ unliteral s + binP s = maybe (showText s) (binP :: a -> Text) $ unliteral s - hex s = maybe (T.pack $ show s) (hex :: a -> Text) $ unliteral s - bin s = maybe (T.pack $ show s) (bin :: a -> Text) $ unliteral s + hex s = maybe (showText s) (hex :: a -> Text) $ unliteral s + bin s = maybe (showText s) (bin :: a -> Text) $ unliteral s -- | Show as a hexadecimal value. First bool controls whether type info is printed -- while the second boolean controls whether 0x prefix is printed. The tuple is @@ -248,12 +220,12 @@ shex :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> Text shex shType shPre (signed, size) a | a < 0 - = T.pack "-" <> pre <> T.pack (pad l (s16 (abs (fromIntegral a :: Integer)))) <> t + = "-" <> pre <> T.pack (pad l (s16 (abs (fromIntegral a :: Integer)))) <> t | True = pre <> T.pack (pad l (s16 a)) <> t - where t | shType = T.pack " :: " <> T.pack (if signed then "Int" else "Word") <> T.pack (show size) + where t | shType = " :: " <> (if signed then "Int" else "Word") <> showText size | True = T.empty - pre | shPre = T.pack "0x" + pre | shPre = "0x" | True = T.empty l = (size + 3) `div` 4 @@ -290,36 +262,36 @@ shexI :: Bool -> Bool -> Integer -> Text shexI shType shPre a | a < 0 - = T.pack "-" <> pre <> T.pack (s16 (abs a)) <> t + = "-" <> pre <> T.pack (s16 (abs a)) <> t | True = pre <> T.pack (s16 a) <> t - where t | shType = T.pack " :: Integer" + where t | shType = " :: Integer" | True = T.empty - pre | shPre = T.pack "0x" + pre | shPre = "0x" | True = T.empty -- | Similar to 'shex'; except in binary. sbin :: (Show a, Integral a) => Bool -> Bool -> (Bool, Int) -> a -> Text sbin shType shPre (signed,size) a | a < 0 - = T.pack "-" <> pre <> T.pack (pad size (s2 (abs (fromIntegral a :: Integer)))) <> t + = "-" <> pre <> T.pack (pad size (s2 (abs (fromIntegral a :: Integer)))) <> t | True = pre <> T.pack (pad size (s2 a)) <> t - where t | shType = T.pack " :: " <> T.pack (if signed then "Int" else "Word") <> T.pack (show size) + where t | shType = " :: " <> (if signed then "Int" else "Word") <> showText size | True = T.empty - pre | shPre = T.pack "0b" + pre | shPre = "0b" | True = T.empty -- | Similar to 'shexI'; except in binary. sbinI :: Bool -> Bool -> Integer -> Text sbinI shType shPre a | a < 0 - = T.pack "-" <> pre <> T.pack (s2 (abs a)) <> t + = "-" <> pre <> T.pack (s2 (abs a)) <> t | True = pre <> T.pack (s2 a) <> t - where t | shType = T.pack " :: Integer" + where t | shType = " :: Integer" | True = T.empty - pre | shPre = T.pack "0b" + pre | shPre = "0b" | True = T.empty -- | Pad a string to a given length. If the string is longer, then we don't drop anything. @@ -341,7 +313,7 @@ [(a, "")] -> a _ -> error $ "SBV.readBin: Cannot read a binary number from: " ++ show s where cvt c = ord c - ord '0' - isDigit = (`elem` "01") + isDigit = (`elem` ("01" :: String)) s' | "0b" `isPrefixOf` s = drop 2 s | True = s @@ -378,53 +350,52 @@ | True = show d -- | A version of show for floats that generates correct SMTLib literals using the rounding mode -showSMTFloat :: RoundingMode -> Float -> String -showSMTFloat rm f +showSMTFloat :: Float -> Text +showSMTFloat f | isNaN f = as "NaN" | isInfinite f, f < 0 = as "-oo" | isInfinite f = as "+oo" | isNegativeZero f = as "-zero" | f == 0 = as "+zero" - | True = "((_ to_fp 8 24) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational f) ++ ")" - where as s = "(_ " ++ s ++ " 8 24)" - + | True = let w = floatToWord f + b i = if w `testBit` i then '1' else '0' + s = T.pack [b 31] + e = T.pack [b i | i <- [30, 29 .. 23]] + m = T.pack [b i | i <- [22, 21 .. 0]] + in "(fp #b" <> s <> " #b" <> e <> " #b" <> m <> ")" + where as s = "(_ " <> s <> " 8 24)" -- | A version of show for doubles that generates correct SMTLib literals using the rounding mode -showSMTDouble :: RoundingMode -> Double -> String -showSMTDouble rm d +showSMTDouble :: Double -> Text +showSMTDouble d | isNaN d = as "NaN" | isInfinite d, d < 0 = as "-oo" | isInfinite d = as "+oo" | isNegativeZero d = as "-zero" | d == 0 = as "+zero" - | True = "((_ to_fp 11 53) " ++ smtRoundingMode rm ++ " " ++ toSMTLibRational (toRational d) ++ ")" - where as s = "(_ " ++ s ++ " 11 53)" + | True = let w = doubleToWord d + b i = if w `testBit` i then '1' else '0' + s = T.pack [b 63] + e = T.pack [b i | i <- [62, 61 .. 52]] + m = T.pack [b i | i <- [51, 50 .. 0]] + in "(fp #b" <> s <> " #b" <> e <> " #b" <> m <> ")" + where as s = "(_ " <> s <> " 11 53)" -- | Show an SBV rational as an SMTLib value. This is used for faithful rationals. -showSMTRational :: Rational -> String -showSMTRational r = "(SBV.Rational " ++ showNegativeNumber (numerator r) ++ " " ++ showNegativeNumber (denominator r) ++ ")" - --- | Show a rational in SMTLib format. This is used for conversions from regular rationals. -toSMTLibRational :: Rational -> String -toSMTLibRational r - | n < 0 - = "(- (/ " ++ show (abs n) ++ ".0 " ++ show d ++ ".0))" - | True - = "(/ " ++ show n ++ ".0 " ++ show d ++ ".0)" - where n = numerator r - d = denominator r +showSMTRational :: Rational -> Text +showSMTRational r = "(SBV.Rational " <> showNegativeNumber (numerator r) <> " " <> showNegativeNumber (denominator r) <> ")" -- | Convert a CV to an SMTLib2 compliant value -cvToSMTLib :: RoundingMode -> CV -> String -cvToSMTLib rm x +cvToSMTLib :: CV -> Text +cvToSMTLib x | isBoolean x, CInteger w <- cvVal x = if w == 0 then "false" else "true" | isRoundingMode x, CADT (s, []) <- cvVal x = roundModeConvert s - | isReal x, CAlgReal r <- cvVal x = algRealToSMTLib2 r - | isFloat x, CFloat f <- cvVal x = showSMTFloat rm f - | isDouble x, CDouble d <- cvVal x = showSMTDouble rm d + | isReal x, CAlgReal r <- cvVal x = T.pack (algRealToSMTLib2 r) | isRational x, CRational r <- cvVal x = showSMTRational r - | isFP x, CFP f <- cvVal x = fprToSMTLib2 f - | not (isBounded x), CInteger w <- cvVal x = if w >= 0 then show w else "(- " ++ show (abs w) ++ ")" + | isFloat x, CFloat f <- cvVal x = showSMTFloat f + | isDouble x, CDouble d <- cvVal x = showSMTDouble d + | isFP x, CFP f <- cvVal x = T.pack (fprToSMTLib2 f) + | not (isBounded x), CInteger w <- cvVal x = if w >= 0 then showText w else "(- " <> showText (abs w) <> ")" | not (hasSign x) , CInteger w <- cvVal x = smtLibHex (intSizeOf x) w -- signed numbers (with 2's complement representation) is problematic -- since there's no way to put a bvneg over a positive number to get minBound.. @@ -432,8 +403,8 @@ | hasSign x , CInteger w <- cvVal x = if w == negate (2 ^ intSizeOf x) then mkMinBound (intSizeOf x) else negIf (w < 0) $ smtLibHex (intSizeOf x) (abs w) - | isChar x , CChar c <- cvVal x = "(_ char " ++ smtLibHex 8 (fromIntegral (ord c)) ++ ")" - | isString x , CString s <- cvVal x = '\"' : stringToQFS s ++ "\"" + | isChar x , CChar c <- cvVal x = "(_ char " <> smtLibHex 8 (fromIntegral (ord c)) <> ")" + | isString x , CString s <- cvVal x = "\"" <> T.pack (stringToQFS s) <> "\"" | isList x , CList xs <- cvVal x = smtLibSeq (kindOf x) xs | isSet x , CSet s <- cvVal x = smtLibSet (kindOf x) s | isTuple x , CTuple xs <- cvVal x = smtLibTup (kindOf x) xs @@ -445,29 +416,29 @@ | isADT x , CADT c <- cvVal x = smtLibADT (cvKind x) c | True = error $ "SBV.cvtCV: Impossible happened: Kind/Value disagreement on: " ++ show (kindOf x, x) - where roundModeConvert s = fromMaybe s (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s]) + where roundModeConvert s = fromMaybe (T.pack s) (listToMaybe [smtRoundingMode m | m <- [minBound .. maxBound] :: [RoundingMode], show m == s]) -- Carefully code hex numbers, SMTLib is picky about lengths of hex constants. For the time -- being, SBV only supports sizes that are multiples of 4, but the below code is more robust -- in case of future extensions to support arbitrary sizes. - smtLibHex :: Int -> Integer -> String - smtLibHex 1 v = "#b" ++ show v + smtLibHex :: Int -> Integer -> Text + smtLibHex 1 v = "#b" <> showText v smtLibHex sz v - | sz `mod` 4 == 0 = "#x" ++ pad (sz `div` 4) (showHex v "") - | True = "#b" ++ pad sz (showBin v "") + | sz `mod` 4 == 0 = "#x" <> T.pack (pad (sz `div` 4) (showHex v "")) + | True = "#b" <> T.pack (pad sz (showBin v "")) where showBin = showIntAtBase 2 intToDigit - negIf :: Bool -> String -> String - negIf True a = "(bvneg " ++ a ++ ")" + negIf :: Bool -> Text -> Text + negIf True a = "(bvneg " <> a <> ")" negIf False a = a - smtLibSeq :: Kind -> [CVal] -> String - smtLibSeq k [] = "(as seq.empty " ++ smtType k ++ ")" + smtLibSeq :: Kind -> [CVal] -> Text + smtLibSeq k [] = "(as seq.empty " <> smtType k <> ")" smtLibSeq (KList ek) xs = let mkSeq [e] = e - mkSeq es = "(seq.++ " ++ unwords es ++ ")" - mkUnit inner = "(seq.unit " ++ inner ++ ")" - in mkSeq (mkUnit . cvToSMTLib rm . CV ek <$> xs) - smtLibSeq k _ = error "SBV.cvToSMTLib: Impossible case (smtLibSeq), received kind: " ++ show k + mkSeq es = "(seq.++ " <> T.unwords es <> ")" + mkUnit inner = "(seq.unit " <> inner <> ")" + in mkSeq (mkUnit . cvToSMTLib . CV ek <$> xs) + smtLibSeq k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibSeq), received kind: " ++ show k - smtLibSet :: Kind -> RCSet CVal -> String + smtLibSet :: Kind -> RCSet CVal -> Text smtLibSet k set = case set of RegularSet rs -> Set.foldr' (modify "true") (start "false") rs ComplementSet rs -> Set.foldr' (modify "false") (start "true") rs @@ -475,38 +446,38 @@ KSet ek -> ek _ -> error $ "SBV.cvToSMTLib: Impossible case (smtLibSet), received kind: " ++ show k - start def = "((as const " ++ smtType k ++ ") " ++ def ++ ")" + start def = "((as const " <> smtType k <> ") " <> def <> ")" - modify how e s = "(store " ++ s ++ " " ++ cvToSMTLib rm (CV ke e) ++ " " ++ how ++ ")" + modify how e s = "(store " <> s <> " " <> cvToSMTLib (CV ke e) <> " " <> how <> ")" - smtLibTup :: Kind -> [CVal] -> String + smtLibTup :: Kind -> [CVal] -> Text smtLibTup (KTuple []) _ = "mkSBVTuple0" - smtLibTup (KTuple ks) xs = "(mkSBVTuple" ++ show (length ks) ++ " " ++ unwords (zipWith (\ek e -> cvToSMTLib rm (CV ek e)) ks xs) ++ ")" + smtLibTup (KTuple ks) xs = "(mkSBVTuple" <> showText (length ks) <> " " <> T.unwords (zipWith (\ek e -> cvToSMTLib (CV ek e)) ks xs) <> ")" smtLibTup k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibTup), received kind: " ++ show k -- Remember that in an ArrayModel we keep a history; i.e., the earlier elements are written later. So, we reverse the assocs - smtLibArray :: Kind -> ArrayModel CVal CVal -> String + smtLibArray :: Kind -> ArrayModel CVal CVal -> Text smtLibArray k@(KArray k1 k2) (ArrayModel assocs def) = mkStoreChain k k1 k2 (reverse assocs) def smtLibArray k _ = error $ "SBV.cvToSMTLib: Impossible case (smtLibArray), received non-matching kind: " ++ show k mkStoreChain k k1 k2 writes def = walk writes base - where base = "((as const " ++ smtType k ++ ") " ++ cvToSMTLib rm (CV k2 def) ++ ")" + where base = "((as const " <> smtType k <> ") " <> cvToSMTLib (CV k2 def) <> ")" walk [] sofar = sofar walk ((key, val) : rest) sofar = walk rest (store key val sofar) - store key val sofar = "(store " ++ sofar ++ " " ++ cvToSMTLib rm (CV k1 key) ++ " " ++ cvToSMTLib rm (CV k2 val) ++ ")" + store key val sofar = "(store " <> sofar <> " " <> cvToSMTLib (CV k1 key) <> " " <> cvToSMTLib (CV k2 val) <> ")" -- anomaly at the 2's complement min value! Have to use binary notation here -- as there is no positive value we can provide to make the bvneg work.. (see above) - mkMinBound :: Int -> String - mkMinBound i = "#b1" ++ replicate (i-1) '0' + mkMinBound :: Int -> Text + mkMinBound i = "#b1" <> T.replicate (i-1) "0" -- ADTs - smtLibADT :: Kind -> (String, [(Kind, CVal)]) -> String + smtLibADT :: Kind -> (String, [(Kind, CVal)]) -> Text smtLibADT knd (c, []) = ascribe c knd - smtLibADT knd (c, kvs) = '(' : ascribe c knd ++ " " ++ unwords (map (\(k, v) -> cvToSMTLib rm (CV k v)) kvs) ++ ")" - ascribe nm k = "(as " ++ nm ++ " " ++ smtType k ++ ")" + smtLibADT knd (c, kvs) = "(" <> ascribe c knd <> " " <> T.unwords (map (\(k, v) -> cvToSMTLib (CV k v)) kvs) <> ")" + ascribe nm k = "(as " <> T.pack nm <> " " <> smtType k <> ")" -- | Show a float as a binary showBFloat :: (Show a, RealFloat a) => a -> ShowS @@ -570,7 +541,7 @@ | True = '<' : show v ++ ">" -- | When we show a negative number in SMTLib, we must properly parenthesize. -showNegativeNumber :: (Show a, Num a, Ord a) => a -> String +showNegativeNumber :: (Show a, Num a, Ord a) => a -> Text showNegativeNumber i - | i < 0 = "(- " ++ show (-i) ++ ")" - | True = show i + | i < 0 = "(- " <> showText (-i) <> ")" + | True = showText i diff --git a/Data/SBV/Utils/SExpr.hs b/Data/SBV/Utils/SExpr.hs --- a/Data/SBV/Utils/SExpr.hs +++ b/Data/SBV/Utils/SExpr.hs @@ -104,7 +104,7 @@ if null extras then case sexp of EApp [ECon "error", ECon er] -> Left $ "Solver returned an error: " ++ er - _ -> return sexp + _ -> pure sexp else die "Extra tokens after valid input" where inpToks = tokenize inp @@ -115,21 +115,21 @@ parse [] = die "ran out of tokens" parse ("(":toks) = do (f, r) <- parseApp toks [] f' <- cvt (EApp f) - return (f', r) + pure (f', r) parse (")":_) = die "extra tokens after close paren" parse [tok] = do t <- pTok tok - return (t, []) + pure (t, []) parse _ = die "ill-formed s-expr" parseApp [] _ = die "failed to grab s-expr application" - parseApp (")":toks) sofar = return (reverse sofar, toks) + parseApp (")":toks) sofar = pure (reverse sofar, toks) parseApp ("(":toks) sofar = do (f, r) <- parse ("(":toks) parseApp r (f : sofar) parseApp (tok:toks) sofar = do t <- pTok tok parseApp toks (t : sofar) - pTok "false" = return $ ENum (0, Nothing, True) - pTok "true" = return $ ENum (1, Nothing, True) + pTok "false" = pure $ ENum (0, Nothing, True) + pTok "true" = pure $ ENum (1, Nothing, True) pTok ('0':'b':r) = mkNum (Just (length r)) $ readInt 2 (`elem` "01") (\c -> ord c - ord '0') r pTok ('b':'v':r) | not (null r) && all isDigit r = mkNum Nothing $ readDec (takeWhile (/= '[') r) @@ -137,7 +137,7 @@ pTok ('#':'x':r) = mkNum (Just (4 * length r)) $ readHex r pTok n | possiblyNum n = if all intChar n then mkNum Nothing $ readSigned readDec n else getReal n - pTok n = return $ ECon (constantMap n) + pTok n = pure $ ECon (constantMap n) -- crude, but effective! possiblyNum s = case s of @@ -147,10 +147,10 @@ intChar c = c == '-' || isDigit c - mkNum l [(n, "")] = return $ ENum (n, l, False) + mkNum l [(n, "")] = pure $ ENum (n, l, False) mkNum _ _ = die "cannot read number" - getReal n = return $ EReal $ mkPolyReal (Left (exact, n')) + getReal n = pure $ EReal $ mkPolyReal (Left (exact, n')) where exact = not ("?" `isPrefixOf` reverse n) n' | exact = n | True = init n @@ -160,19 +160,19 @@ thd3 (_, _, c) = c -- simplify numbers and root-obj values - cvt (EApp [ECon "to_int", EReal a]) = return $ EReal a -- ignore the "casting" - cvt (EApp [ECon "to_real", EReal a]) = return $ EReal a -- ignore the "casting" - cvt (EApp [ECon "/", EReal a, EReal b]) = return $ EReal (a / b) - cvt (EApp [ECon "/", EReal a, ENum b]) = return $ EReal (a / fromInteger (fst3 b)) - cvt (EApp [ECon "/", ENum a, EReal b]) = return $ EReal (fromInteger (fst3 a) / b ) - cvt (EApp [ECon "/", ENum a, ENum b]) = return $ EReal (fromInteger (fst3 a) / fromInteger (fst3 b)) - cvt (EApp [ECon "-", EReal a]) = return $ EReal (-a) - cvt (EApp [ECon "-", ENum a]) = return $ ENum (-(fst3 a), snd3 a, thd3 a) + cvt (EApp [ECon "to_int", EReal a]) = pure $ EReal a -- ignore the "casting" + cvt (EApp [ECon "to_real", EReal a]) = pure $ EReal a -- ignore the "casting" + cvt (EApp [ECon "/", EReal a, EReal b]) = pure $ EReal (a / b) + cvt (EApp [ECon "/", EReal a, ENum b]) = pure $ EReal (a / fromInteger (fst3 b)) + cvt (EApp [ECon "/", ENum a, EReal b]) = pure $ EReal (fromInteger (fst3 a) / b ) + cvt (EApp [ECon "/", ENum a, ENum b]) = pure $ EReal (fromInteger (fst3 a) / fromInteger (fst3 b)) + cvt (EApp [ECon "-", EReal a]) = pure $ EReal (-a) + cvt (EApp [ECon "-", ENum a]) = pure $ ENum (-(fst3 a), snd3 a, thd3 a) -- bit-vector value as CVC4 prints: (_ bv0 16) for instance - cvt (EApp [ECon "_", ENum a, ENum _b]) = return $ ENum a + cvt (EApp [ECon "_", ENum a, ENum _b]) = pure $ ENum a cvt (EApp [ECon "root-obj", EApp (ECon "+":trms), ENum k]) = do ts <- mapM getCoeff trms - return $ EReal $ mkPolyReal (Right (fst3 k, ts)) + pure $ EReal $ mkPolyReal (Right (fst3 k, ts)) cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FloatingPoint", ENum (11, _, _), ENum (53, _, _)]]) = getDouble n cvt (EApp [ECon "as", n, EApp [ECon "_", ECon "FloatingPoint", ENum ( 8, _, _), ENum (24, _, _)]]) = getFloat n cvt (EApp [ECon "as", n, ECon "Float64"]) = getDouble n @@ -183,10 +183,10 @@ , EApp [ECon "or", EApp [ECon "=", ECon v', val], _]]) | v == v' = do approx <- cvt val case approx of - ENum (s, _, _) -> return $ EReal $ mkPolyReal (Left (False, show s)) + ENum (s, _, _) -> pure $ EReal $ mkPolyReal (Left (False, show s)) EReal aval -> case aval of - AlgRational _ r -> return $ EReal $ AlgRational False r - _ -> return $ EReal aval + AlgRational _ r -> pure $ EReal $ AlgRational False r + _ -> pure $ EReal aval _ -> die $ "Cannot parse a CVC4 approximate value from: " ++ show x -- Deal with CVC5's algebraic reals. This is very crude! @@ -194,83 +194,83 @@ let isComma (ECon ",") = True isComma _ = False - get (ENum (n, _, _)) = return $ fromIntegral n - get (EReal (AlgRational True r)) = return r - get (EFloat f) = return $ toRational f - get (EDouble d) = return $ toRational d + get (ENum (n, _, _)) = pure $ fromIntegral n + get (EReal (AlgRational True r)) = pure r + get (EFloat f) = pure $ toRational f + get (EDouble d) = pure $ toRational d get t = die $ "Cannot get a CVC5 real-algebraic bound from: " ++ show t in case drop 1 (dropWhile (not . isComma) rest) of [EApp [n1, n2], _] -> do low <- get n1 high <- get n2 - return $ EReal $ AlgInterval (OpenPoint low) (OpenPoint high) + pure $ EReal $ AlgInterval (OpenPoint low) (OpenPoint high) _ -> die $ "Cannot parse a CVC5 real-algebraic number from: " ++ show x -- NB. Note the lengths on the mantissa for the following two are 23/52; not 24/53! - cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 8, _), ENum (m, Just 23, _)]) = return $ EFloat $ getTripleFloat s e m - cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 11, _), ENum (m, Just 52, _)]) = return $ EDouble $ getTripleDouble s e m - cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just eb, _), ENum (m, Just sb, _)]) = return $ EFloatingPoint $ fpFromRawRep (s == 1) (e, eb) (m, sb+1) + cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 8, _), ENum (m, Just 23, _)]) = pure $ EFloat $ getTripleFloat s e m + cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just 11, _), ENum (m, Just 52, _)]) = pure $ EDouble $ getTripleDouble s e m + cvt (EApp [ECon "fp", ENum (s, Just 1, _), ENum ( e, Just eb, _), ENum (m, Just sb, _)]) = pure $ EFloatingPoint $ fpFromRawRep (s == 1) (e, eb) (m, sb+1) - cvt (EApp [ECon "_", ECon "NaN", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat nan - cvt (EApp [ECon "_", ECon "NaN", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble nan - cvt (EApp [ECon "_", ECon "NaN", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpNaN (fromIntegral eb) (fromIntegral sb) + cvt (EApp [ECon "_", ECon "NaN", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat nan + cvt (EApp [ECon "_", ECon "NaN", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble nan + cvt (EApp [ECon "_", ECon "NaN", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpNaN (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "+oo", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat infinity - cvt (EApp [ECon "_", ECon "+oo", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble infinity - cvt (EApp [ECon "_", ECon "+oo", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpInf False (fromIntegral eb) (fromIntegral sb) + cvt (EApp [ECon "_", ECon "+oo", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat infinity + cvt (EApp [ECon "_", ECon "+oo", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble infinity + cvt (EApp [ECon "_", ECon "+oo", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpInf False (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "-oo", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat $ -infinity - cvt (EApp [ECon "_", ECon "-oo", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble $ -infinity - cvt (EApp [ECon "_", ECon "-oo", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpInf True (fromIntegral eb) (fromIntegral sb) + cvt (EApp [ECon "_", ECon "-oo", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat $ -infinity + cvt (EApp [ECon "_", ECon "-oo", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble $ -infinity + cvt (EApp [ECon "_", ECon "-oo", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpInf True (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "+zero", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat 0 - cvt (EApp [ECon "_", ECon "+zero", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble 0 - cvt (EApp [ECon "_", ECon "+zero", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpZero False (fromIntegral eb) (fromIntegral sb) + cvt (EApp [ECon "_", ECon "+zero", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat 0 + cvt (EApp [ECon "_", ECon "+zero", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble 0 + cvt (EApp [ECon "_", ECon "+zero", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpZero False (fromIntegral eb) (fromIntegral sb) - cvt (EApp [ECon "_", ECon "-zero", ENum ( 8, _, _), ENum (24, _, _)]) = return $ EFloat $ -0 - cvt (EApp [ECon "_", ECon "-zero", ENum (11, _, _), ENum (53, _, _)]) = return $ EDouble $ -0 - cvt (EApp [ECon "_", ECon "-zero", ENum (eb, _, _), ENum (sb, _, _)]) = return $ EFloatingPoint $ fpZero True (fromIntegral eb) (fromIntegral sb) + cvt (EApp [ECon "_", ECon "-zero", ENum ( 8, _, _), ENum (24, _, _)]) = pure $ EFloat $ -0 + cvt (EApp [ECon "_", ECon "-zero", ENum (11, _, _), ENum (53, _, _)]) = pure $ EDouble $ -0 + cvt (EApp [ECon "_", ECon "-zero", ENum (eb, _, _), ENum (sb, _, _)]) = pure $ EFloatingPoint $ fpZero True (fromIntegral eb) (fromIntegral sb) - cvt x = return x + cvt x = pure x - getCoeff (EApp [ECon "*", ENum k, EApp [ECon "^", ECon "x", ENum p]]) = return (fst3 k, fst3 p) -- kx^p - getCoeff (EApp [ECon "*", ENum k, ECon "x" ] ) = return (fst3 k, 1) -- kx - getCoeff ( EApp [ECon "^", ECon "x", ENum p] ) = return ( 1, fst3 p) -- x^p - getCoeff ( ECon "x" ) = return ( 1, 1) -- x - getCoeff ( ENum k ) = return (fst3 k, 0) -- k + getCoeff (EApp [ECon "*", ENum k, EApp [ECon "^", ECon "x", ENum p]]) = pure (fst3 k, fst3 p) -- kx^p + getCoeff (EApp [ECon "*", ENum k, ECon "x" ] ) = pure (fst3 k, 1) -- kx + getCoeff ( EApp [ECon "^", ECon "x", ENum p] ) = pure ( 1, fst3 p) -- x^p + getCoeff ( ECon "x" ) = pure ( 1, 1) -- x + getCoeff ( ENum k ) = pure (fst3 k, 0) -- k getCoeff x = die $ "Cannot parse a root-obj,\nProcessing term: " ++ show x getDouble (ECon s) = case (s, rdFP (dropWhile (== '+') s)) of - ("plusInfinity", _ ) -> return $ EDouble infinity - ("minusInfinity", _ ) -> return $ EDouble (-infinity) - ("oo", _ ) -> return $ EDouble infinity - ("-oo", _ ) -> return $ EDouble (-infinity) - ("zero", _ ) -> return $ EDouble 0 - ("-zero", _ ) -> return $ EDouble (-0) - ("NaN", _ ) -> return $ EDouble nan - (_, Just v) -> return $ EDouble v + ("plusInfinity", _ ) -> pure $ EDouble infinity + ("minusInfinity", _ ) -> pure $ EDouble (-infinity) + ("oo", _ ) -> pure $ EDouble infinity + ("-oo", _ ) -> pure $ EDouble (-infinity) + ("zero", _ ) -> pure $ EDouble 0 + ("-zero", _ ) -> pure $ EDouble (-0) + ("NaN", _ ) -> pure $ EDouble nan + (_, Just v) -> pure $ EDouble v _ -> die $ "Cannot parse a double value from: " ++ s getDouble (EApp [_, s, _, _]) = getDouble s - getDouble (EReal r) = return $ EDouble $ fromRat $ toRational r + getDouble (EReal r) = pure $ EDouble $ fromRat $ toRational r getDouble x = die $ "Cannot parse a double value from: " ++ show x getFloat (ECon s) = case (s, rdFP (dropWhile (== '+') s)) of - ("plusInfinity", _ ) -> return $ EFloat infinity - ("minusInfinity", _ ) -> return $ EFloat (-infinity) - ("oo", _ ) -> return $ EFloat infinity - ("-oo", _ ) -> return $ EFloat (-infinity) - ("zero", _ ) -> return $ EFloat 0 - ("-zero", _ ) -> return $ EFloat (-0) - ("NaN", _ ) -> return $ EFloat nan - (_, Just v) -> return $ EFloat v + ("plusInfinity", _ ) -> pure $ EFloat infinity + ("minusInfinity", _ ) -> pure $ EFloat (-infinity) + ("oo", _ ) -> pure $ EFloat infinity + ("-oo", _ ) -> pure $ EFloat (-infinity) + ("zero", _ ) -> pure $ EFloat 0 + ("-zero", _ ) -> pure $ EFloat (-0) + ("NaN", _ ) -> pure $ EFloat nan + (_, Just v) -> pure $ EFloat v _ -> die $ "Cannot parse a float value from: " ++ s - getFloat (EReal r) = return $ EFloat $ fromRat $ toRational r + getFloat (EReal r) = pure $ EFloat $ fromRat $ toRational r getFloat (EApp [_, s, _, _]) = getFloat s getFloat x = die $ "Cannot parse a float value from: " ++ show x -- | Parses the Z3 floating point formatted numbers like so: 1.321p5/1.2123e9 etc. rdFP :: (Read a, RealFloat a) => String -> Maybe a rdFP s = case break (`elem` "pe") s of - (m, 'p':e) -> rd m >>= \m' -> rd e >>= \e' -> return $ m' * ( 2 ** e') - (m, 'e':e) -> rd m >>= \m' -> rd e >>= \e' -> return $ m' * (10 ** e') + (m, 'p':e) -> rd m >>= \m' -> rd e >>= \e' -> pure $ m' * ( 2 ** e') + (m, 'e':e) -> rd m >>= \m' -> rd e >>= \e' -> pure $ m' * (10 ** e') (m, "") -> rd m _ -> Nothing where rd v = case reads v of @@ -504,10 +504,10 @@ parseStoreAssociations (EApp [ECon "_", ECon "as-array", ECon nm]) = Just $ Left nm parseStoreAssociations e = Right <$> (chainAssigns =<< vals e) where vals :: SExpr -> Maybe [Either ([SExpr], SExpr) SExpr] - vals (EApp [EApp [ECon "as", ECon "const", ECon "Array"], defVal]) = return [Right defVal] - vals (EApp [EApp [ECon "as", ECon "const", EApp (ECon "Array" : _)], defVal]) = return [Right defVal] + vals (EApp [EApp [ECon "as", ECon "const", ECon "Array"], defVal]) = pure [Right defVal] + vals (EApp [EApp [ECon "as", ECon "const", EApp (ECon "Array" : _)], defVal]) = pure [Right defVal] vals (EApp (ECon "store" : prev : argsVal)) | length argsVal >= 2 = do rest <- vals prev - return $ Left (init argsVal, last argsVal) : rest + pure $ Left (init argsVal, last argsVal) : rest vals _ = Nothing -- | Turn a sequence of left-right chain assignments (condition + free) into a single chain @@ -576,7 +576,7 @@ Right (EApp [EApp [ECon o, e]]) | o == nm -> do (args, bd) <- lambda e let params | isCurried = unwords args | True = '(' : intercalate ", " args ++ ")" - return $ unBar nm ++ " " ++ params ++ " = " ++ bd + pure $ unBar nm ++ " " ++ params ++ " = " ++ bd _ -> Nothing where -- infinite supply of names; starting with the ones we're given diff --git a/Documentation/SBV/Examples/ADT/Param.hs b/Documentation/SBV/Examples/ADT/Param.hs --- a/Documentation/SBV/Examples/ADT/Param.hs +++ b/Documentation/SBV/Examples/ADT/Param.hs @@ -155,9 +155,9 @@ -- | Query mode example. -- -- >>> queryE --- e1: (let p = (-3 * 1) in (-1 * p)) +-- e1: (let h = (-3 * -1) in (1 * h)) -- e2: -2 --- e3: (let p = 314 % 315 in p) +-- e3: (let d = 368 % 369 in d) queryE :: IO () queryE = runSMT $ do e1 :: SExpr String Integer <- free "e1" diff --git a/Documentation/SBV/Examples/ADT/Types.hs b/Documentation/SBV/Examples/ADT/Types.hs --- a/Documentation/SBV/Examples/ADT/Types.hs +++ b/Documentation/SBV/Examples/ADT/Types.hs @@ -42,7 +42,7 @@ -- types, we'll simply use an uninterpreted function. Note that -- this also implies we consider all terms to be given so that variables -- do not shadow each other; i.e., all variables are unique. This is --- a simplification, but it is not without justification: One can +-- a simplification, but it is not without justification: One can -- always alpha-rename bound variables so all bound variables are unique. env :: SString -> ST env = uninterpret "env" diff --git a/Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs b/Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs --- a/Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs +++ b/Documentation/SBV/Examples/BitPrecise/BrokenSearch.hs @@ -110,6 +110,6 @@ mid = f low high - return $ sFromIntegral mid .== mid' + pure $ sFromIntegral mid .== mid' {- HLint ignore module "Reduce duplication" -} diff --git a/Documentation/SBV/Examples/BitPrecise/Legato.hs b/Documentation/SBV/Examples/BitPrecise/Legato.hs --- a/Documentation/SBV/Examples/BitPrecise/Legato.hs +++ b/Documentation/SBV/Examples/BitPrecise/Legato.hs @@ -294,7 +294,7 @@ flagC <- sBool "flagC" flagZ <- sBool "flagZ" - return $ legatoIsCorrect (x, y, lo, regX, regA, flagC, flagZ) + pure $ legatoIsCorrect (x, y, lo, regX, regA, flagC, flagZ) ------------------------------------------------------------------ -- * C Code generation diff --git a/Documentation/SBV/Examples/BitPrecise/MergeSort.hs b/Documentation/SBV/Examples/BitPrecise/MergeSort.hs --- a/Documentation/SBV/Examples/BitPrecise/MergeSort.hs +++ b/Documentation/SBV/Examples/BitPrecise/MergeSort.hs @@ -53,7 +53,7 @@ There are two main parts to proving that a sorting algorithm is correct: * Prove that the output is non-decreasing - + * Prove that the output is a permutation of the input -} @@ -88,7 +88,7 @@ correctness :: Int -> IO ThmResult correctness n = prove $ do xs <- mkFreeVars n let ys = mergeSort xs - return $ nonDecreasing ys .&& isPermutationOf xs ys + pure $ nonDecreasing ys .&& isPermutationOf xs ys ----------------------------------------------------------------------------- -- * Generating C code diff --git a/Documentation/SBV/Examples/BitPrecise/PrefixSum.hs b/Documentation/SBV/Examples/BitPrecise/PrefixSum.hs --- a/Documentation/SBV/Examples/BitPrecise/PrefixSum.hs +++ b/Documentation/SBV/Examples/BitPrecise/PrefixSum.hs @@ -13,7 +13,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-} @@ -85,7 +85,7 @@ flIsCorrect :: Int -> (forall a. (OrdSymbolic a, Num a, Bits a) => (a, a -> a -> a)) -> Symbolic SBool flIsCorrect n zf = do args :: PowerList SWord32 <- mkFreeVars n - return $ ps zf args .== lf zf args + pure $ ps zf args .== lf zf args -- | Proves Ladner-Fischer is equivalent to reference specification for addition. -- @0@ is the left-unit element, and we use a power-list of size @8@. We have: diff --git a/Documentation/SBV/Examples/CodeGeneration/Fibonacci.hs b/Documentation/SBV/Examples/CodeGeneration/Fibonacci.hs --- a/Documentation/SBV/Examples/CodeGeneration/Fibonacci.hs +++ b/Documentation/SBV/Examples/CodeGeneration/Fibonacci.hs @@ -107,7 +107,7 @@ -- > const SWord64 s32 = s6 ? 0x0000000000000001ULL : s31; -- > const SWord64 s33 = s4 ? 0x0000000000000001ULL : s32; -- > const SWord64 s34 = s2 ? 0x0000000000000000ULL : s33; --- > +-- > -- > return s34; -- > } genFib1 :: SWord64 -> IO () @@ -176,7 +176,7 @@ -- > 0x000003af9a19bbd9ULL, 0x000005f6c7b064e2ULL, 0x000009a661ca20bbULL -- > }; -- > const SWord64 s65 = s0 >= 65 ? 0x0000000000000000ULL : table0[s0]; --- > +-- > -- > return s65; -- > } genFib2 :: Word64 -> IO () diff --git a/Documentation/SBV/Examples/CodeGeneration/GCD.hs b/Documentation/SBV/Examples/CodeGeneration/GCD.hs --- a/Documentation/SBV/Examples/CodeGeneration/GCD.hs +++ b/Documentation/SBV/Examples/CodeGeneration/GCD.hs @@ -88,14 +88,14 @@ -- precisely the same amount of time for all values of @x@ and @y@. -- -- > /* File: "sgcd.c". Automatically generated by SBV. Do not edit! */ --- > +-- > -- > #include -- > #include -- > #include -- > #include -- > #include -- > #include "sgcd.h" --- > +-- > -- > SWord8 sgcd(const SWord8 x, const SWord8 y) -- > { -- > const SWord8 s0 = x; @@ -146,7 +146,7 @@ -- > const SWord8 s46 = s9 ? s5 : s45; -- > const SWord8 s47 = s6 ? s1 : s46; -- > const SWord8 s48 = s3 ? s0 : s47; --- > +-- > -- > return s48; -- > } genGCDInC :: IO () diff --git a/Documentation/SBV/Examples/Crypto/AES.hs b/Documentation/SBV/Examples/Crypto/AES.hs --- a/Documentation/SBV/Examples/Crypto/AES.hs +++ b/Documentation/SBV/Examples/Crypto/AES.hs @@ -29,11 +29,7 @@ {-# LANGUAGE ParallelListComp #-} {-# LANGUAGE TypeApplications #-} -#if MIN_VERSION_base(4,19,0) {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-} -#else -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} -#endif module Documentation.SBV.Examples.Crypto.AES where diff --git a/Documentation/SBV/Examples/Crypto/Prince.hs b/Documentation/SBV/Examples/Crypto/Prince.hs --- a/Documentation/SBV/Examples/Crypto/Prince.hs +++ b/Documentation/SBV/Examples/Crypto/Prince.hs @@ -14,7 +14,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE ParallelListComp #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} module Documentation.SBV.Examples.Crypto.Prince where @@ -131,8 +131,8 @@ -- Q.E.D. prop_sr :: Predicate prop_sr = do b <- free "block" - return $ b .== sr (srInv b) - .&& b .== srInv (sr b) + pure $ b .== sr (srInv b) + .&& b .== srInv (sr b) -- | M' transformation m' :: Block -> Block @@ -189,8 +189,8 @@ -- Q.E.D. prop_SBox :: Predicate prop_SBox = do b <- free "block" - return $ b .== sBoxInv (sBox b) - .&& b .== sBox (sBoxInv b) + pure $ b .== sBoxInv (sBox b) + .&& b .== sBox (sBoxInv b) -- * Round constants diff --git a/Documentation/SBV/Examples/Crypto/RC4.hs b/Documentation/SBV/Examples/Crypto/RC4.hs --- a/Documentation/SBV/Examples/Crypto/RC4.hs +++ b/Documentation/SBV/Examples/Crypto/RC4.hs @@ -144,7 +144,7 @@ let ks = keySchedule key ct = zipWith xor ks pt pt' = zipWith xor ks ct - return $ pt .== pt' + pure $ pt .== pt' -------------------------------------------------------------------------------------------- -- | For doctest purposes only diff --git a/Documentation/SBV/Examples/Existentials/Diophantine.hs b/Documentation/SBV/Examples/Existentials/Diophantine.hs --- a/Documentation/SBV/Examples/Existentials/Diophantine.hs +++ b/Documentation/SBV/Examples/Existentials/Diophantine.hs @@ -70,10 +70,10 @@ ldn :: forall proxy n. KnownNat n => proxy n -> Maybe Int -> [([Integer], Integer)] -> IO Solution ldn pn mbLim problem = do solution <- basis pn mbLim (map (map literal) m) if homogeneous - then return $ Homogeneous solution + then pure $ Homogeneous solution else do let ones = [xs | (1:xs) <- solution] zeros = [xs | (0:xs) <- solution] - return $ NonHomogeneous ones zeros + pure $ NonHomogeneous ones zeros where rhs = map snd problem lhs = map fst problem homogeneous = all (== 0) rhs @@ -170,5 +170,5 @@ , ([0, 0, 0, 0, 0, 4, -5], 1) ] case soln of - NonHomogeneous (xs:_) _ -> return xs + NonHomogeneous (xs:_) _ -> pure xs _ -> search (i+1) diff --git a/Documentation/SBV/Examples/Lists/BoundedMutex.hs b/Documentation/SBV/Examples/Lists/BoundedMutex.hs --- a/Documentation/SBV/Examples/Lists/BoundedMutex.hs +++ b/Documentation/SBV/Examples/Lists/BoundedMutex.hs @@ -110,7 +110,7 @@ -- -- >>> notFair 10 -- Fairness is violated at bound: 10 --- P1: [Idle,Idle,Idle,Idle,Ready,Critical,Critical,Critical,Idle,Ready] +-- P1: [Idle,Idle,Idle,Idle,Ready,Critical,Idle,Ready,Critical,Critical] -- P2: [Idle,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready,Ready] -- Ts: [1,1,1,1,1,1,1,1,1,1] -- diff --git a/Documentation/SBV/Examples/Misc/Auxiliary.hs b/Documentation/SBV/Examples/Misc/Auxiliary.hs --- a/Documentation/SBV/Examples/Misc/Auxiliary.hs +++ b/Documentation/SBV/Examples/Misc/Auxiliary.hs @@ -28,7 +28,7 @@ y <- free "y" constrain $ x .>= 0 constrain $ x .<= 1 - return $ x - abs y .== (0 :: SInteger) + pure $ x - abs y .== (0 :: SInteger) -- | Generate all satisfying assignments for our problem. We have: -- diff --git a/Documentation/SBV/Examples/Misc/Floating.hs b/Documentation/SBV/Examples/Misc/Floating.hs --- a/Documentation/SBV/Examples/Misc/Floating.hs +++ b/Documentation/SBV/Examples/Misc/Floating.hs @@ -90,7 +90,7 @@ -- make sure we do not overflow at the intermediate points constrain $ fpIsPoint lhs constrain $ fpIsPoint rhs - return $ lhs .== rhs + pure $ lhs .== rhs ----------------------------------------------------------------------------- -- * FP addition by non-zero can result in no change @@ -118,7 +118,7 @@ constrain $ fpIsPoint a constrain $ fpIsPoint b constrain $ a + b .== a - return $ b .== 0 + pure $ b .== 0 ----------------------------------------------------------------------------- -- * FP multiplicative inverses may not exist @@ -142,7 +142,7 @@ multInverse = prove $ do a <- sFloat "a" constrain $ fpIsPoint a constrain $ fpIsPoint (1/a) - return $ a * (1/a) .== 1 + pure $ a * (1/a) .== 1 ----------------------------------------------------------------------------- -- * Effect of rounding modes @@ -189,7 +189,7 @@ let rhs = x + y constrain $ fpIsPoint lhs constrain $ fpIsPoint rhs - return $ lhs ./= rhs + pure $ lhs ./= rhs -- | Arbitrary precision floating-point numbers. SBV can talk about floating point numbers with arbitrary -- exponent and significand sizes as well. Here is a simple example demonstrating the minimum non-zero positive diff --git a/Documentation/SBV/Examples/Misc/ModelExtract.hs b/Documentation/SBV/Examples/Misc/ModelExtract.hs --- a/Documentation/SBV/Examples/Misc/ModelExtract.hs +++ b/Documentation/SBV/Examples/Misc/ModelExtract.hs @@ -25,7 +25,7 @@ outside disallow = sat $ do x <- sInteger "x" let notEq i = constrain $ x ./= literal i mapM_ notEq disallow - return $ x .>= 0 + pure $ x .>= 0 -- | We now use "outside" repeatedly to generate 10 integers, such that we not only disallow -- previously generated elements, but also any value that differs from previous solutions @@ -37,7 +37,7 @@ genVals :: IO [Integer] genVals = go [] [] where go _ model - | length model >= 10 = return model + | length model >= 10 = pure model go disallow model = do res <- outside disallow -- Look up the value of "x" in the generated model @@ -45,4 +45,4 @@ -- SBV known type would be OK as well. case "x" `getModelValue` res of Just c -> go ([c-4 .. c+4] ++ disallow) (c : model) - _ -> return model + _ -> pure model diff --git a/Documentation/SBV/Examples/Misc/Newtypes.hs b/Documentation/SBV/Examples/Misc/Newtypes.hs --- a/Documentation/SBV/Examples/Misc/Newtypes.hs +++ b/Documentation/SBV/Examples/Misc/Newtypes.hs @@ -94,4 +94,4 @@ humanHeight :: SHumanHeightInCm <- free "humanheight" constrain $ humanHeight .== tallestHumanEver - return $ ceilingHighEnoughForHuman ceiling humanHeight + pure $ ceilingHighEnoughForHuman ceiling humanHeight diff --git a/Documentation/SBV/Examples/Misc/SoftConstrain.hs b/Documentation/SBV/Examples/Misc/SoftConstrain.hs --- a/Documentation/SBV/Examples/Misc/SoftConstrain.hs +++ b/Documentation/SBV/Examples/Misc/SoftConstrain.hs @@ -44,4 +44,4 @@ softConstrain $ x .== "default-x-value" softConstrain $ y .== "default-y-value" - return sTrue + pure sTrue diff --git a/Documentation/SBV/Examples/ProofTools/BMC.hs b/Documentation/SBV/Examples/ProofTools/BMC.hs --- a/Documentation/SBV/Examples/ProofTools/BMC.hs +++ b/Documentation/SBV/Examples/ProofTools/BMC.hs @@ -59,7 +59,7 @@ -- calls to 'Data.SBV.setOption'. We do not need any for this problem, -- so we simply do nothing. setup :: Symbolic () - setup = return () + setup = pure () -- Transition relation: At each step we either -- get to increase @x@ by 2, or decrement @y@ by 4: diff --git a/Documentation/SBV/Examples/ProofTools/Strengthen.hs b/Documentation/SBV/Examples/ProofTools/Strengthen.hs --- a/Documentation/SBV/Examples/ProofTools/Strengthen.hs +++ b/Documentation/SBV/Examples/ProofTools/Strengthen.hs @@ -68,7 +68,7 @@ -- calls to 'Data.SBV.setOption'. We do not need any for this problem, -- so we simply do nothing. setup :: Symbolic () - setup = return () + setup = pure () -- Initially, @x@ and @y@ are both @1@ initial :: S SInteger -> SBool diff --git a/Documentation/SBV/Examples/ProofTools/Sum.hs b/Documentation/SBV/Examples/ProofTools/Sum.hs --- a/Documentation/SBV/Examples/ProofTools/Sum.hs +++ b/Documentation/SBV/Examples/ProofTools/Sum.hs @@ -60,7 +60,7 @@ -- calls to 'Data.SBV.setOption'. We do not need any for this problem, -- so we simply do nothing. setup :: Symbolic () - setup = return () + setup = pure () -- Initially, @s@ and @i@ are both @0@. We also require @n@ to be at least @0@. initial :: S SInteger -> SBool diff --git a/Documentation/SBV/Examples/Puzzles/Coins.hs b/Documentation/SBV/Examples/Puzzles/Coins.hs --- a/Documentation/SBV/Examples/Puzzles/Coins.hs +++ b/Documentation/SBV/Examples/Puzzles/Coins.hs @@ -44,7 +44,7 @@ mkCoin :: Int -> Symbolic Coin mkCoin i = do c <- free $ 'c' : show i constrain $ sAny (.== c) [1, 5, 10, 25, 50, 100] - return c + pure c -- | Return all combinations of a sequence of values. combinations :: [a] -> [[a]] @@ -105,4 +105,4 @@ constrain $ sAnd $ zipWith (.>=) cs (drop 1 cs) -- assert that the sum must be 115 cents. - return $ sum cs .== 115 + pure $ sum cs .== 115 diff --git a/Documentation/SBV/Examples/Puzzles/Euler185.hs b/Documentation/SBV/Examples/Puzzles/Euler185.hs --- a/Documentation/SBV/Examples/Puzzles/Euler185.hs +++ b/Documentation/SBV/Examples/Puzzles/Euler185.hs @@ -34,7 +34,7 @@ -- number of matching digits match what's given in the problem statement. euler185 :: Symbolic SBool euler185 = do soln <- mkFreeVars 16 - return $ sAll digit soln .&& sAnd (map (genConstr soln) guesses) + pure $ sAll digit soln .&& sAnd (map (genConstr soln) guesses) where genConstr a (b, c) = sum (zipWith eq a b) .== (c :: SWord8) digit x = (x :: SWord8) .>= 0 .&& x .<= 9 eq x y = ite (x .== fromIntegral (ord y - ord '0')) 1 0 diff --git a/Documentation/SBV/Examples/Puzzles/Sudoku.hs b/Documentation/SBV/Examples/Puzzles/Sudoku.hs --- a/Documentation/SBV/Examples/Puzzles/Sudoku.hs +++ b/Documentation/SBV/Examples/Puzzles/Sudoku.hs @@ -9,16 +9,13 @@ -- The Sudoku solver, quintessential SMT solver example! ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Puzzles.Sudoku where -#if MIN_VERSION_base(4,18,0) import Control.Monad (when, zipWithM_) -#endif import Control.Monad.State.Lazy diff --git a/Documentation/SBV/Examples/Puzzles/U2Bridge.hs b/Documentation/SBV/Examples/Puzzles/U2Bridge.hs --- a/Documentation/SBV/Examples/Puzzles/U2Bridge.hs +++ b/Documentation/SBV/Examples/Puzzles/U2Bridge.hs @@ -15,7 +15,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Puzzles.U2Bridge where @@ -114,7 +114,7 @@ let (ar, s1) = runState a s (br, s2) = runState b s put $ symbolicMerge f t s1 s2 - return $ symbolicMerge f t ar br + pure $ symbolicMerge f t ar br -- | Read the state via an accessor function peek :: (Status -> a) -> Move a @@ -133,7 +133,10 @@ -- | Transferring a person to the other side xferPerson :: SU2Member -> Move () -xferPerson p = do ~[lb, le, la, ll] <- mapM peek [lBono, lEdge, lAdam, lLarry] +xferPerson p = do lb <- peek lBono + le <- peek lEdge + la <- peek lAdam + ll <- peek lLarry let move l = ite (l .== sHere) sThere sHere lb' = ite (p .== sBono) (move lb) lb le' = ite (p .== sEdge) (move le) le @@ -151,7 +154,7 @@ -- | Symbolic version of 'Control.Monad.when' whenS :: SBool -> Move () -> Move () -whenS t a = ite t a (return ()) +whenS t a = ite t a (pure ()) -- | Move one member, remembering to take the flash move1 :: SU2Member -> Move () @@ -215,19 +218,19 @@ let genAct = do b <- free_ p1 <- free_ p2 <- free_ - return (b, p1, p2) + pure (b, p1, p2) res <- allSat $ isValid `fmap` mapM (const genAct) [1..n] cnt <- displayModels (sortOn show) disp res - if cnt == 0 then return False + if cnt == 0 then pure False else do putStrLn $ "Found: " ++ show cnt ++ " solution" ++ plu cnt ++ " with " ++ show n ++ " move" ++ plu n ++ "." - return True + pure True where plu v = if v == 1 then "" else "s" disp :: Int -> (Bool, [(Bool, U2Member, U2Member)]) -> IO () disp i (_, ss) | lss /= n = error $ "Expected " ++ show n ++ " results; got: " ++ show lss | True = do putStrLn $ "Solution #" ++ show i ++ ":" go False 0 ss - return () + pure () where lss = length ss go _ t [] = putStrLn $ "Total time: " ++ show t go l t ((True, a, _):rest) = do putStrLn $ sh2 t ++ shL l ++ show a diff --git a/Documentation/SBV/Examples/Queries/AllSat.hs b/Documentation/SBV/Examples/Queries/AllSat.hs --- a/Documentation/SBV/Examples/Queries/AllSat.hs +++ b/Documentation/SBV/Examples/Queries/AllSat.hs @@ -45,7 +45,7 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!" - return $ reverse sofar + pure $ reverse sofar Sat -> do xv <- getValue x yv <- getValue y diff --git a/Documentation/SBV/Examples/Queries/CaseSplit.hs b/Documentation/SBV/Examples/Queries/CaseSplit.hs --- a/Documentation/SBV/Examples/Queries/CaseSplit.hs +++ b/Documentation/SBV/Examples/Queries/CaseSplit.hs @@ -54,7 +54,7 @@ case mbR of Nothing -> error "Cannot find a FP number x such that x /= x" -- Won't happen! Just (s, _) -> do xv <- getValue x - return (s, xv) + pure (s, xv) -- | Demonstrates the "coverage" case. -- @@ -82,4 +82,4 @@ case mbR of Nothing -> error "Cannot find a solution!" -- Won't happen! Just (s, _) -> do xv <- getValue x - return (s, xv) + pure (s, xv) diff --git a/Documentation/SBV/Examples/Queries/Concurrency.hs b/Documentation/SBV/Examples/Queries/Concurrency.hs --- a/Documentation/SBV/Examples/Queries/Concurrency.hs +++ b/Documentation/SBV/Examples/Queries/Concurrency.hs @@ -61,12 +61,12 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!" - return Nothing + pure Nothing Sat -> do xv <- getValue x yv <- getValue y io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv) - return $ Just (xv + yv) + pure $ Just (xv + yv) -- | In the second query we constrain for an answer where y is smaller than x, -- and then return the product of the found values. @@ -81,12 +81,12 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!" - return Nothing + pure Nothing Sat -> do yv <- getValue y xv <- getValue x io $ putStrLn $ "[Two]: Current solution is: " ++ show (xv, yv) - return $ Just (xv * yv) + pure $ Just (xv * yv) -- | Run the demo several times to see that the children threads will change ordering. demo :: IO () @@ -125,14 +125,14 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!" - return Nothing + pure Nothing Sat -> do xv <- getValue x yv <- getValue y io $ putStrLn $ "[One]: Current solution is: " ++ show (xv, yv) io $ putStrLn "[One]: Place vars for [Two]" liftIO $ putMVar v2 (literal (xv + yv), literal (xv * yv)) - return $ Just (xv + yv) + pure $ Just (xv + yv) -- | In the second query we create a new variable z, and then a symbolic query -- using information from the first query and return a solution that uses the @@ -153,13 +153,13 @@ Unk -> error "Too bad, solver said unknown.." -- Won't happen DSat{} -> error "Unexpected dsat result.." -- Won't happen Unsat -> do io $ putStrLn "No other solution!" - return Nothing + pure Nothing Sat -> do yv <- getValue y xv <- getValue x zv <- getValue z io $ putStrLn $ "[Two]: My solution is: " ++ show (zv + xv, zv + yv) - return $ Just (zv * xv * yv) + pure $ Just (zv * xv * yv) -- | In our second demonstration we show how through the use of concurrency -- constructs the user can have children queries communicate with one another. diff --git a/Documentation/SBV/Examples/Queries/Enums.hs b/Documentation/SBV/Examples/Queries/Enums.hs --- a/Documentation/SBV/Examples/Queries/Enums.hs +++ b/Documentation/SBV/Examples/Queries/Enums.hs @@ -60,6 +60,6 @@ Sat -> do a <- getValue d1 b <- getValue d2 c <- getValue d3 - return [a, b, c] + pure [a, b, c] _ -> error "Impossible, can't find days!" diff --git a/Documentation/SBV/Examples/Queries/FourFours.hs b/Documentation/SBV/Examples/Queries/FourFours.hs --- a/Documentation/SBV/Examples/Queries/FourFours.hs +++ b/Documentation/SBV/Examples/Queries/FourFours.hs @@ -91,7 +91,7 @@ fill :: T () () -> Symbolic (T SBinOp SUnOp) fill (B _ l r) = B <$> free_ <*> fill l <*> fill r fill (U _ t) = U <$> free_ <*> fill t -fill F = return F +fill F = pure F -- | Minor helper for writing "symbolic" case statements. Simply walks down a list -- of values to match against a symbolic version of the key. @@ -109,27 +109,27 @@ eval tree = case tree of B b l r -> eval l >>= \l' -> eval r >>= \r' -> binOp b l' r' U u t -> eval t >>= uOp u - F -> return 4 + F -> pure 4 where binOp :: SBinOp -> SInteger -> SInteger -> Symbolic SInteger binOp o l r = do constrain $ o .== sDivide .=> r .== 4 .|| r .== 2 constrain $ o .== sExpt .=> r .== 0 - return $ cases o - [ (Plus, l+r) - , (Minus, l-r) - , (Times, l*r) - , (Divide, l `sDiv` r) - , (Expt, 1) -- exponent is restricted to 0, so the value is 1 - ] + pure $ cases o + [ (Plus, l+r) + , (Minus, l-r) + , (Times, l*r) + , (Divide, l `sDiv` r) + , (Expt, 1) -- exponent is restricted to 0, so the value is 1 + ] uOp :: SUnOp -> SInteger -> Symbolic SInteger uOp o v = do constrain $ o .== sSqrt .=> v .== 4 constrain $ o .== sFactorial .=> v .== 4 - return $ cases o - [ (Negate, -v) - , (Sqrt, 2) -- argument is restricted to 4, so the value is 2 - , (Factorial, 24) -- argument is restricted to 4, so the value is 24 - ] + pure $ cases o + [ (Negate, -v) + , (Sqrt, 2) -- argument is restricted to 4, so the value is 2 + , (Factorial, 24) -- argument is restricted to 4, so the value is 24 + ] -- | In the query mode, find a filling of a given tree shape /t/, such that it evaluates to the -- requested number /i/. Note that we return back a concrete tree. @@ -140,10 +140,10 @@ query $ do cs <- checkSat case cs of Sat -> Just <$> construct symT - _ -> return Nothing + _ -> pure Nothing where -- Walk through the tree, ask the solver for -- the assignment to symbolic operators and fill back. - construct F = return F + construct F = pure F construct (U o s') = do uo <- getValue o U uo <$> construct s' construct (B b l' r') = do bo <- getValue b diff --git a/Documentation/SBV/Examples/Queries/GuessNumber.hs b/Documentation/SBV/Examples/Queries/GuessNumber.hs --- a/Documentation/SBV/Examples/Queries/GuessNumber.hs +++ b/Documentation/SBV/Examples/Queries/GuessNumber.hs @@ -50,7 +50,7 @@ Sat -> do gv <- getValue g case gv `compare` input of EQ -> -- Got it, return: - return (reverse (gv : sofar)) + pure (reverse (gv : sofar)) LT -> -- Solver guess is too small, increase the lower bound: loop ((lb+1) `max` (lb + (input - lb) `div` 2)) ub (gv : sofar) GT -> -- Solver guess is too big, decrease the upper bound: diff --git a/Documentation/SBV/Examples/Queries/UnsatCore.hs b/Documentation/SBV/Examples/Queries/UnsatCore.hs --- a/Documentation/SBV/Examples/Queries/UnsatCore.hs +++ b/Documentation/SBV/Examples/Queries/UnsatCore.hs @@ -36,7 +36,7 @@ query $ do cs <- checkSat case cs of Unsat -> Just <$> getUnsatCore - _ -> return Nothing + _ -> pure Nothing -- | Extract the unsat-core of 'p'. We have: diff --git a/Documentation/SBV/Examples/Strings/RegexCrossword.hs b/Documentation/SBV/Examples/Strings/RegexCrossword.hs --- a/Documentation/SBV/Examples/Strings/RegexCrossword.hs +++ b/Documentation/SBV/Examples/Strings/RegexCrossword.hs @@ -34,7 +34,7 @@ let mkRow rowRegExp = do row :: SString <- free_ constrain $ row `R.match` rowRegExp constrain $ L.length row .== literal numCols - return row + pure row rows <- mapM mkRow rowRegExps @@ -42,7 +42,7 @@ let mkCol colRegExp = do col :: SString <- free_ constrain $ col `R.match` colRegExp constrain $ L.length col .== literal numRows - return col + pure col cols <- mapM mkCol colRegExps diff --git a/Documentation/SBV/Examples/Strings/SQLInjection.hs b/Documentation/SBV/Examples/Strings/SQLInjection.hs --- a/Documentation/SBV/Examples/Strings/SQLInjection.hs +++ b/Documentation/SBV/Examples/Strings/SQLInjection.hs @@ -49,11 +49,11 @@ eval (Query q) = do q' <- eval q tell [q'] lift $ lift free_ -eval (Const str) = return $ literal str +eval (Const str) = pure $ literal str eval (Concat e1 e2) = (++) <$> eval e1 <*> eval e2 eval (ReadVar nm) = do n <- eval nm arr <- get - return $ readArray arr n + pure $ readArray arr n -- | A simple program to query all messages with a given topic id. In SQL like notation: -- diff --git a/Documentation/SBV/Examples/TP/Ackermann.hs b/Documentation/SBV/Examples/TP/Ackermann.hs --- a/Documentation/SBV/Examples/TP/Ackermann.hs +++ b/Documentation/SBV/Examples/TP/Ackermann.hs @@ -75,15 +75,15 @@ -- -- >>> runTP ack_2_2_4 -- Inductive lemma (strong): ack_2_2_4 --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ack -- [Proven] ack_2_2_4 :: Ɐm ∷ Integer → Bool ack_2_2_4 :: TP (Proof (Forall "m" Integer -> SBool)) @@ -106,16 +106,16 @@ -- -- >>> runTP ack_psd -- Inductive lemma (strong): ack_psd --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. --- Step: 1.4.1 Q.E.D. --- Step: 1.4.2 Q.E.D. --- Step: 1.4.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. +-- Step: 1.4.1 Q.E.D. +-- Step: 1.4.2 Q.E.D. +-- Step: 1.4.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ack -- [Proven] ack_psd :: Ɐm ∷ Integer → Ɐn ∷ Integer → Ɐa ∷ Integer → Bool ack_psd :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> Forall "a" Integer -> SBool)) @@ -142,17 +142,17 @@ -- -- >>> runTPWith cvc5 pet_psd -- Inductive lemma (strong): pet_psd --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: pet -- [Proven] pet_psd :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool pet_psd :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool)) @@ -182,46 +182,46 @@ -- -- >>> runTPWith cvc5 petAck -- Inductive lemma (strong): ack_2_2_4 --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): pet_psd --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): petAck --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.3.4 Q.E.D. --- Step: 1.3.5 Q.E.D. --- Step: 1.4.1 Q.E.D. --- Step: 1.4.2 Q.E.D. --- Step: 1.4.3 Q.E.D. --- Step: 1.4.4 Q.E.D. --- Step: 1.4.5 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.3.4 Q.E.D. +-- Step: 1.3.5 Q.E.D. +-- Step: 1.4.1 Q.E.D. +-- Step: 1.4.2 Q.E.D. +-- Step: 1.4.3 Q.E.D. +-- Step: 1.4.4 Q.E.D. +-- Step: 1.4.5 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ack, pet -- [Proven] petAck :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool petAck :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Basics.hs b/Documentation/SBV/Examples/TP/Basics.hs --- a/Documentation/SBV/Examples/TP/Basics.hs +++ b/Documentation/SBV/Examples/TP/Basics.hs @@ -44,7 +44,7 @@ -- We have: -- -- >>> trueIsProvable --- Lemma: true Q.E.D. +-- Lemma: true Q.E.D. -- [Proven] true :: Bool trueIsProvable :: IO (Proof SBool) trueIsProvable = runTP $ lemma "true" sTrue [] @@ -68,7 +68,7 @@ -- -- We have: -- >>> largerIntegerExists --- Lemma: largerIntegerExists Q.E.D. +-- Lemma: largerIntegerExists Q.E.D. -- [Proven] largerIntegerExists :: Ɐx ∷ Integer → ∃y ∷ Integer → Bool largerIntegerExists :: IO (Proof (Forall "x" Integer -> Exists "y" Integer -> SBool)) largerIntegerExists = runTP $ lemma "largerIntegerExists" @@ -80,7 +80,7 @@ -- | Pushing a universal through conjunction. We have: -- -- >>> forallConjunction @Integer (uninterpret "p") (uninterpret "q") --- Lemma: forallConjunction Q.E.D. +-- Lemma: forallConjunction Q.E.D. -- [Proven] forallConjunction :: Bool forallConjunction :: forall a. SymVal a => (SBV a -> SBool) -> (SBV a -> SBool) -> IO (Proof SBool) forallConjunction p q = runTP $ do @@ -96,7 +96,7 @@ -- | Pushing an existential through disjunction. We have: -- -- >>> existsDisjunction @Integer (uninterpret "p") (uninterpret "q") --- Lemma: existsDisjunction Q.E.D. +-- Lemma: existsDisjunction Q.E.D. -- [Proven] existsDisjunction :: Bool existsDisjunction :: forall a. SymVal a => (SBV a -> SBool) -> (SBV a -> SBool) -> IO (Proof SBool) existsDisjunction p q = runTP $ do @@ -180,7 +180,7 @@ -- Lemma: qcExample -- Step: 1 (passed 1000 tests) Q.E.D. [Modulo: quickCheck] -- Step: 2 (Failed during quickTest) --- +-- -- *** QuickCheck failed for qcExample.2 -- *** Failed! Assertion failed (after 1 test): -- n = 175 :: Word8 @@ -207,8 +207,8 @@ -- -- >>> runTP (qcFermat 3) -- Lemma: qcFermat 3 --- Step: 1 (qc: Running 1000 tests) QC OK --- Result: Q.E.D. [Modulo: quickCheck] +-- Step: 1 (qc: Running 1000 tests) QC OK +-- Result: Q.E.D. [Modulo: quickCheck] -- [Modulo: quickCheck] qcFermat 3 :: Ɐx ∷ Integer → Ɐy ∷ Integer → Ɐz ∷ Integer → Bool qcFermat :: Integer -> TP (Proof (Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> SBool)) qcFermat e = calc ("qcFermat " <> show e) @@ -228,7 +228,7 @@ -- verified the termination of @sumToN@ before proceeding with the proof. -- -- >>> terminationDemo --- Lemma: sumToN_at_5 Q.E.D. +-- Lemma: sumToN_at_5 Q.E.D. -- Functions proven terminating: sumToN -- [Proven] sumToN_at_5 :: Ɐn ∷ Integer → Bool terminationDemo :: IO (Proof (Forall "n" Integer -> SBool)) @@ -308,8 +308,8 @@ -- >>> axiomsAreDangerous -- Axiom: bad -- Lemma: axiomsCanBeInconsistent --- Step: 1 (bad @ (n |-> 0 :: SInteger)) Q.E.D. --- Result: Q.E.D. +-- Step: 1 (bad @ (n |-> 0 :: SInteger)) Q.E.D. +-- Result: Q.E.D. -- [Proven] axiomsCanBeInconsistent :: Bool axiomsAreDangerous :: IO (Proof SBool) axiomsAreDangerous = runTP $ do @@ -379,7 +379,7 @@ -- 'lemma' proves from scratch and correctly fails: -- -- >>> runTP duplicateNames `catch` (\(_ :: SomeException) -> pure ()) --- Lemma: evil Q.E.D. +-- Lemma: evil Q.E.D. -- Lemma: evil -- *** Failed to prove evil. -- Falsifiable diff --git a/Documentation/SBV/Examples/TP/BinarySearch.hs b/Documentation/SBV/Examples/TP/BinarySearch.hs --- a/Documentation/SBV/Examples/TP/BinarySearch.hs +++ b/Documentation/SBV/Examples/TP/BinarySearch.hs @@ -63,52 +63,52 @@ -- We have: -- -- >>> correctness --- Lemma: notInRange Q.E.D. --- Lemma: inRangeHigh Q.E.D. --- Lemma: inRangeLow Q.E.D. --- Lemma: nonDecreasing Q.E.D. +-- Lemma: notInRange Q.E.D. +-- Lemma: inRangeHigh Q.E.D. +-- Lemma: inRangeLow Q.E.D. +-- Lemma: nonDecreasing Q.E.D. -- Inductive lemma (strong): bsearchAbsent --- Step: Measure is non-negative Q.E.D. --- Step: 1 (unfold bsearch) Q.E.D. --- Step: 2 (push isNothing down, simplify) Q.E.D. +-- Step: Measure is non-negative Q.E.D. +-- Step: 1 (unfold bsearch) Q.E.D. +-- Step: 2 (push isNothing down, simplify) Q.E.D. -- Step: 3 (2 way case split) --- Step: 3.1 Q.E.D. --- Step: 3.2.1 Q.E.D. --- Step: 3.2.2 Q.E.D. --- Step: 3.2.3 Q.E.D. --- Step: 3.2.4 Q.E.D. --- Step: 3.2.5 (simplify) Q.E.D. --- Step: 3.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 3.1 Q.E.D. +-- Step: 3.2.1 Q.E.D. +-- Step: 3.2.2 Q.E.D. +-- Step: 3.2.3 Q.E.D. +-- Step: 3.2.4 Q.E.D. +-- Step: 3.2.5 (simplify) Q.E.D. +-- Step: 3.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): bsearchPresent --- Step: Measure is non-negative Q.E.D. --- Step: 1 (unfold bsearch) Q.E.D. --- Step: 2 (simplify) Q.E.D. +-- Step: Measure is non-negative Q.E.D. +-- Step: 1 (unfold bsearch) Q.E.D. +-- Step: 2 (simplify) Q.E.D. -- Step: 3 (3 way case split) --- Step: 3.1 Q.E.D. --- Step: 3.2 Q.E.D. --- Step: 3.3.1 Q.E.D. +-- Step: 3.1 Q.E.D. +-- Step: 3.2 Q.E.D. +-- Step: 3.3.1 Q.E.D. -- Step: 3.3.2 (3 way case split) --- Step: 3.3.2.1 Q.E.D. --- Step: 3.3.2.2.1 Q.E.D. --- Step: 3.3.2.2.2 Q.E.D. --- Step: 3.3.2.3.1 Q.E.D. --- Step: 3.3.2.3.2 Q.E.D. --- Step: 3.3.2.Completeness Q.E.D. --- Step: 3.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 3.3.2.1 Q.E.D. +-- Step: 3.3.2.2.1 Q.E.D. +-- Step: 3.3.2.2.2 Q.E.D. +-- Step: 3.3.2.3.1 Q.E.D. +-- Step: 3.3.2.3.2 Q.E.D. +-- Step: 3.3.2.Completeness Q.E.D. +-- Step: 3.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: bsearchCorrect -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: bsearch -- [Proven] bsearchCorrect :: Ɐarr ∷ (ArrayModel Integer Integer) → Ɐlo ∷ Integer → Ɐhi ∷ Integer → Ɐx ∷ Integer → Bool correctness :: IO (Proof (Forall "arr" (ArrayModel Integer Integer) -> Forall "lo" Integer -> Forall "hi" Integer -> Forall "x" Integer -> SBool)) -correctness = runTPWith (tpRibbon 50 cvc5) $ do +correctness = runTPWith cvc5 $ do -- Helper: if a value is not in a range, then it isn't in any subrange of it: notInRange <- lemma "notInRange" diff --git a/Documentation/SBV/Examples/TP/CaseSplit.hs b/Documentation/SBV/Examples/TP/CaseSplit.hs --- a/Documentation/SBV/Examples/TP/CaseSplit.hs +++ b/Documentation/SBV/Examples/TP/CaseSplit.hs @@ -25,11 +25,11 @@ -- >>> notDiv3 -- Lemma: notDiv3 -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- [Proven] notDiv3 :: Ɐn ∷ Integer → Bool notDiv3 :: IO (Proof (Forall "n" Integer -> SBool)) notDiv3 = runTP $ do diff --git a/Documentation/SBV/Examples/TP/Coins.hs b/Documentation/SBV/Examples/TP/Coins.hs --- a/Documentation/SBV/Examples/TP/Coins.hs +++ b/Documentation/SBV/Examples/TP/Coins.hs @@ -79,17 +79,17 @@ -- -- >>> runTP correctness -- Inductive lemma (strong): mkChangeCorrect --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (5 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. --- Step: 1.4 Q.E.D. --- Step: 1.5.1 Q.E.D. --- Step: 1.5.2 Q.E.D. --- Step: 1.5.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. +-- Step: 1.4 Q.E.D. +-- Step: 1.5.1 Q.E.D. +-- Step: 1.5.2 Q.E.D. +-- Step: 1.5.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: mkChange -- [Proven] mkChangeCorrect :: Ɐn ∷ Integer → Bool correctness :: TP (Proof (Forall "n" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Collatz.hs b/Documentation/SBV/Examples/TP/Collatz.hs --- a/Documentation/SBV/Examples/TP/Collatz.hs +++ b/Documentation/SBV/Examples/TP/Collatz.hs @@ -61,7 +61,7 @@ -- | Doubling doesn't change the Collatz result. -- -- >>> runTP doubling --- Lemma: doubling Q.E.D. [Modulo: collatz termination] +-- Lemma: doubling Q.E.D. [Modulo: collatz termination] -- [Modulo: collatz termination] doubling :: Ɐn ∷ Integer → Bool doubling :: TP (Proof (Forall "n" Integer -> SBool)) doubling = lemma "doubling" (\(Forall @"n" n) -> n .>= 1 .=> collatz (2 * n) .== collatz n) [] @@ -70,10 +70,10 @@ -- -- >>> runTP pow2pos -- Inductive lemma: pow2pos --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: pow2 -- [Proven] pow2pos :: Ɐk ∷ Integer → Bool pow2pos :: TP (Proof (Forall "k" Integer -> SBool)) @@ -91,14 +91,14 @@ -- | All powers of two reach 1 under the Collatz function. -- -- >>> runTP collatzPow2 --- Lemma: doubling Q.E.D. [Modulo: collatz termination] --- Lemma: pow2pos Q.E.D. +-- Lemma: doubling Q.E.D. [Modulo: collatz termination] +-- Lemma: pow2pos Q.E.D. -- Inductive lemma: collatzPow2 --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. [Modulo: collatz termination] --- Step: 3 Q.E.D. --- Result: Q.E.D. [Modulo: collatz termination] +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. [Modulo: collatz termination] +-- Step: 3 Q.E.D. +-- Result: Q.E.D. [Modulo: collatz termination] -- Functions proven terminating: pow2 -- [Modulo: collatz termination] collatzPow2 :: Ɐk ∷ Integer → Bool collatzPow2 :: TP (Proof (Forall "k" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/ConstFold.hs b/Documentation/SBV/Examples/TP/ConstFold.hs --- a/Documentation/SBV/Examples/TP/ConstFold.hs +++ b/Documentation/SBV/Examples/TP/ConstFold.hs @@ -140,7 +140,7 @@ -- | The size measure is always non-negative. -- -- >>> runTP measureNonNeg --- Lemma: measureNonNeg Q.E.D. +-- Lemma: measureNonNeg Q.E.D. -- Functions proven terminating: exprSize -- [Proven] measureNonNeg :: Ɐe ∷ (Expr String Integer) → Bool measureNonNeg :: TP (Proof (Forall "e" Exp -> SBool)) @@ -151,7 +151,7 @@ -- | Congruence for squaring: if @a == b@ then @a*a == b*b@. -- -- >>> runTP sqrCong --- Lemma: sqrCong Q.E.D. +-- Lemma: sqrCong Q.E.D. -- [Proven] sqrCong :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool sqrCong :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) sqrCong = lemma "sqrCong" @@ -161,7 +161,7 @@ -- | Congruence for addition on the left: if @a == b@ then @a+c == b+c@. -- -- >>> runTP addCongL --- Lemma: addCongL Q.E.D. +-- Lemma: addCongL Q.E.D. -- [Proven] addCongL :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool addCongL :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool)) addCongL = lemma "addCongL" @@ -171,7 +171,7 @@ -- | Congruence for addition on the right: if @b == c@ then @a+b == a+c@. -- -- >>> runTP addCongR --- Lemma: addCongR Q.E.D. +-- Lemma: addCongR Q.E.D. -- [Proven] addCongR :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool addCongR :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool)) addCongR = lemma "addCongR" @@ -181,7 +181,7 @@ -- | Congruence for multiplication on the left: if @a == b@ then @a*c == b*c@. -- -- >>> runTP mulCongL --- Lemma: mulCongL Q.E.D. +-- Lemma: mulCongL Q.E.D. -- [Proven] mulCongL :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool mulCongL :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool)) mulCongL = lemma "mulCongL" @@ -191,7 +191,7 @@ -- | Congruence for multiplication on the right: if @b == c@ then @a*b == a*c@. -- -- >>> runTP mulCongR --- Lemma: mulCongR Q.E.D. +-- Lemma: mulCongR Q.E.D. -- [Proven] mulCongR :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐc ∷ Integer → Bool mulCongR :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "c" Integer -> SBool)) mulCongR = lemma "mulCongR" @@ -201,7 +201,7 @@ -- | Unfolding @interpInEnv@ over @Sqr@. -- -- >>> runTP sqrHelper --- Lemma: sqrHelper Q.E.D. +-- Lemma: sqrHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] sqrHelper :: Ɐenv ∷ [(String, Integer)] → Ɐa ∷ (Expr String Integer) → Bool sqrHelper :: TP (Proof (Forall "env" EL -> Forall "a" Exp -> SBool)) @@ -212,7 +212,7 @@ -- | Unfolding @interpInEnv@ over @Add@. -- -- >>> runTP addHelper --- Lemma: addHelper Q.E.D. +-- Lemma: addHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] addHelper :: Ɐenv ∷ [(String, Integer)] → Ɐa ∷ (Expr String Integer) → Ɐb ∷ (Expr String Integer) → Bool addHelper :: TP (Proof (Forall "env" EL -> Forall "a" Exp -> Forall "b" Exp -> SBool)) @@ -223,7 +223,7 @@ -- | Unfolding @interpInEnv@ over @Mul@. -- -- >>> runTP mulHelper --- Lemma: mulHelper Q.E.D. +-- Lemma: mulHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] mulHelper :: Ɐenv ∷ [(String, Integer)] → Ɐa ∷ (Expr String Integer) → Ɐb ∷ (Expr String Integer) → Bool mulHelper :: TP (Proof (Forall "env" EL -> Forall "a" Exp -> Forall "b" Exp -> SBool)) @@ -234,7 +234,7 @@ -- | Unfolding @interpInEnv@ over @Let@. -- -- >>> runTP letHelper --- Lemma: letHelper Q.E.D. +-- Lemma: letHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] letHelper :: Ɐenv ∷ [(String, Integer)] → Ɐnm ∷ String → Ɐa ∷ (Expr String Integer) → Ɐb ∷ (Expr String Integer) → Bool letHelper :: TP (Proof (Forall "env" EL -> Forall "nm" String -> Forall "a" Exp -> Forall "b" Exp -> SBool)) @@ -249,11 +249,11 @@ -- >>> runTP lookupSwap -- Lemma: lookupSwap -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupSwap :: Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool lookupSwap :: TP (Proof (Forall "k" String -> Forall "b1" (String, Integer) @@ -283,7 +283,7 @@ -- @define-fun-rec@ but struggles to fold it back, so we provide this as a reusable hint. -- -- >>> runTP lookupCons --- Lemma: lookupCons Q.E.D. +-- Lemma: lookupCons Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupCons :: Ɐk ∷ String → Ɐb ∷ (String, Integer) → Ɐrest ∷ [(String, Integer)] → Bool lookupCons :: TP (Proof (Forall "k" String -> Forall "b" (String, Integer) -> Forall "rest" EL -> SBool)) @@ -297,19 +297,19 @@ -- a prefix does not affect lookup. -- -- >>> runTP lookupSwapPfx --- Lemma: lookupSwap Q.E.D. --- Lemma: lookupCons Q.E.D. +-- Lemma: lookupSwap Q.E.D. +-- Lemma: lookupCons Q.E.D. -- Inductive lemma (strong): lookupSwapPfx --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 (base) Q.E.D. --- Step: 1.2.1 (cons) Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.2.5 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 (base) Q.E.D. +-- Step: 1.2.1 (cons) Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.2.5 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupSwapPfx :: Ɐpfx ∷ [(String, Integer)] → Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool lookupSwapPfx :: TP (Proof (Forall "pfx" EL -> Forall "k" String -> Forall "b1" (String, Integer) @@ -356,7 +356,7 @@ -- | A shadowed binding does not affect lookup: if the same key appears first, the second is irrelevant. -- -- >>> runTP lookupShadow --- Lemma: lookupShadow Q.E.D. +-- Lemma: lookupShadow Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupShadow :: Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool lookupShadow :: TP (Proof (Forall "k" String -> Forall "b1" (String, Integer) @@ -373,19 +373,19 @@ -- | Generalized shadow: a shadowed binding behind a prefix does not affect lookup. -- -- >>> runTP lookupShadowPfx --- Lemma: lookupShadow Q.E.D. --- Lemma: lookupCons Q.E.D. +-- Lemma: lookupShadow Q.E.D. +-- Lemma: lookupCons Q.E.D. -- Inductive lemma (strong): lookupShadowPfx --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 (base) Q.E.D. --- Step: 1.2.1 (cons) Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.2.5 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 (base) Q.E.D. +-- Step: 1.2.1 (cons) Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.2.5 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.lookup -- [Proven] lookupShadowPfx :: Ɐpfx ∷ [(String, Integer)] → Ɐk ∷ String → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Ɐenv ∷ [(String, Integer)] → Bool lookupShadowPfx :: TP (Proof (Forall "pfx" EL -> Forall "k" String -> Forall "b1" (String, Integer) @@ -433,40 +433,40 @@ -- to happen at any depth in the environment. -- -- >>> runTPWith cvc5 envSwap --- Lemma: measureNonNeg Q.E.D. --- Lemma: lookupSwapPfx Q.E.D. --- Lemma: sqrCong Q.E.D. --- Lemma: sqrHelper Q.E.D. --- Lemma: addCongL Q.E.D. --- Lemma: addCongR Q.E.D. --- Lemma: addHelper Q.E.D. --- Lemma: mulCongL Q.E.D. --- Lemma: mulCongR Q.E.D. --- Lemma: mulHelper Q.E.D. --- Lemma: letHelper Q.E.D. +-- Lemma: measureNonNeg Q.E.D. +-- Lemma: lookupSwapPfx Q.E.D. +-- Lemma: sqrCong Q.E.D. +-- Lemma: sqrHelper Q.E.D. +-- Lemma: addCongL Q.E.D. +-- Lemma: addCongR Q.E.D. +-- Lemma: addHelper Q.E.D. +-- Lemma: mulCongL Q.E.D. +-- Lemma: mulCongR Q.E.D. +-- Lemma: mulHelper Q.E.D. +-- Lemma: letHelper Q.E.D. -- Inductive lemma (strong): envSwap --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split) --- Step: 1.1 (Var) Q.E.D. --- Step: 1.2 (Con) Q.E.D. --- Step: 1.3.1 (Sqr) Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.4 (Inc) Q.E.D. --- Step: 1.5.1 (Add) Q.E.D. --- Step: 1.5.2 Q.E.D. --- Step: 1.5.3 Q.E.D. --- Step: 1.5.4 Q.E.D. --- Step: 1.6.1 (Mul) Q.E.D. --- Step: 1.6.2 Q.E.D. --- Step: 1.6.3 Q.E.D. --- Step: 1.6.4 Q.E.D. --- Step: 1.7.1 (Let) Q.E.D. --- Step: 1.7.2 Q.E.D. --- Step: 1.7.3 Q.E.D. --- Step: 1.7.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 (Var) Q.E.D. +-- Step: 1.2 (Con) Q.E.D. +-- Step: 1.3.1 (Sqr) Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.4 (Inc) Q.E.D. +-- Step: 1.5.1 (Add) Q.E.D. +-- Step: 1.5.2 Q.E.D. +-- Step: 1.5.3 Q.E.D. +-- Step: 1.5.4 Q.E.D. +-- Step: 1.6.1 (Mul) Q.E.D. +-- Step: 1.6.2 Q.E.D. +-- Step: 1.6.3 Q.E.D. +-- Step: 1.6.4 Q.E.D. +-- Step: 1.7.1 (Let) Q.E.D. +-- Step: 1.7.2 Q.E.D. +-- Step: 1.7.3 Q.E.D. +-- Step: 1.7.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: exprSize, interpInEnv, sbv.lookup -- [Proven] envSwap :: Ɐe ∷ (Expr String Integer) → Ɐpfx ∷ [(String, Integer)] → Ɐenv ∷ [(String, Integer)] → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Bool envSwap :: TP (Proof (Forall "e" Exp -> Forall "pfx" EL -> Forall "env" EL @@ -590,40 +590,40 @@ -- The @pfx@ parameter allows the shadow to occur at any depth. -- -- >>> runTPWith cvc5 envShadow --- Lemma: measureNonNeg Q.E.D. --- Lemma: lookupShadowPfx Q.E.D. --- Lemma: sqrCong Q.E.D. --- Lemma: sqrHelper Q.E.D. --- Lemma: addCongL Q.E.D. --- Lemma: addCongR Q.E.D. --- Lemma: addHelper Q.E.D. --- Lemma: mulCongL Q.E.D. --- Lemma: mulCongR Q.E.D. --- Lemma: mulHelper Q.E.D. --- Lemma: letHelper Q.E.D. +-- Lemma: measureNonNeg Q.E.D. +-- Lemma: lookupShadowPfx Q.E.D. +-- Lemma: sqrCong Q.E.D. +-- Lemma: sqrHelper Q.E.D. +-- Lemma: addCongL Q.E.D. +-- Lemma: addCongR Q.E.D. +-- Lemma: addHelper Q.E.D. +-- Lemma: mulCongL Q.E.D. +-- Lemma: mulCongR Q.E.D. +-- Lemma: mulHelper Q.E.D. +-- Lemma: letHelper Q.E.D. -- Inductive lemma (strong): envShadow --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split) --- Step: 1.1 (Var) Q.E.D. --- Step: 1.2 (Con) Q.E.D. --- Step: 1.3.1 (Sqr) Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.4 (Inc) Q.E.D. --- Step: 1.5.1 (Add) Q.E.D. --- Step: 1.5.2 Q.E.D. --- Step: 1.5.3 Q.E.D. --- Step: 1.5.4 Q.E.D. --- Step: 1.6.1 (Mul) Q.E.D. --- Step: 1.6.2 Q.E.D. --- Step: 1.6.3 Q.E.D. --- Step: 1.6.4 Q.E.D. --- Step: 1.7.1 (Let) Q.E.D. --- Step: 1.7.2 Q.E.D. --- Step: 1.7.3 Q.E.D. --- Step: 1.7.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 (Var) Q.E.D. +-- Step: 1.2 (Con) Q.E.D. +-- Step: 1.3.1 (Sqr) Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.4 (Inc) Q.E.D. +-- Step: 1.5.1 (Add) Q.E.D. +-- Step: 1.5.2 Q.E.D. +-- Step: 1.5.3 Q.E.D. +-- Step: 1.5.4 Q.E.D. +-- Step: 1.6.1 (Mul) Q.E.D. +-- Step: 1.6.2 Q.E.D. +-- Step: 1.6.3 Q.E.D. +-- Step: 1.6.4 Q.E.D. +-- Step: 1.7.1 (Let) Q.E.D. +-- Step: 1.7.2 Q.E.D. +-- Step: 1.7.3 Q.E.D. +-- Step: 1.7.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: exprSize, interpInEnv, sbv.lookup -- [Proven] envShadow :: Ɐe ∷ (Expr String Integer) → Ɐpfx ∷ [(String, Integer)] → Ɐenv ∷ [(String, Integer)] → Ɐb1 ∷ (String, Integer) → Ɐb2 ∷ (String, Integer) → Bool envShadow :: TP (Proof (Forall "e" Exp -> Forall "pfx" EL -> Forall "env" EL @@ -748,7 +748,7 @@ -- | Unfolding @interpInEnv@ over @Var@. -- -- >>> runTP varHelper --- Lemma: varHelper Q.E.D. +-- Lemma: varHelper Q.E.D. -- Functions proven terminating: interpInEnv, sbv.lookup -- [Proven] varHelper :: Ɐenv ∷ [(String, Integer)] → Ɐnm ∷ String → Bool varHelper :: TP (Proof (Forall "env" EL -> Forall "nm" String -> SBool)) @@ -760,63 +760,63 @@ -- is the same as substituting and interpreting in the original environment. -- -- >>> runTPWith cvc5 substCorrect --- Lemma: measureNonNeg Q.E.D. --- Lemma: sqrCong Q.E.D. --- Lemma: sqrHelper Q.E.D. --- Lemma: addHelper Q.E.D. --- Lemma: mulCongL Q.E.D. --- Lemma: mulCongR Q.E.D. --- Lemma: mulHelper Q.E.D. --- Lemma: letHelper Q.E.D. --- Lemma: varHelper Q.E.D. --- Lemma: envSwap Q.E.D. --- Lemma: envShadow Q.E.D. +-- Lemma: measureNonNeg Q.E.D. +-- Lemma: sqrCong Q.E.D. +-- Lemma: sqrHelper Q.E.D. +-- Lemma: addHelper Q.E.D. +-- Lemma: mulCongL Q.E.D. +-- Lemma: mulCongR Q.E.D. +-- Lemma: mulHelper Q.E.D. +-- Lemma: letHelper Q.E.D. +-- Lemma: varHelper Q.E.D. +-- Lemma: envSwap Q.E.D. +-- Lemma: envShadow Q.E.D. -- Inductive lemma (strong): substCorrect --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split) -- Step: 1.1 (2 way case split) --- Step: 1.1.1.1 (Var) Q.E.D. --- Step: 1.1.1.2 Q.E.D. --- Step: 1.1.1.3 Q.E.D. --- Step: 1.1.1.4 Q.E.D. --- Step: 1.1.1.5 Q.E.D. --- Step: 1.1.2.1 (Var) Q.E.D. --- Step: 1.1.2.2 Q.E.D. --- Step: 1.1.2.3 Q.E.D. --- Step: 1.1.2.4 Q.E.D. --- Step: 1.1.2.5 Q.E.D. --- Step: 1.1.Completeness Q.E.D. --- Step: 1.2 (Con) Q.E.D. --- Step: 1.3.1 (Sqr) Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.3.4 Q.E.D. --- Step: 1.4 (Inc) Q.E.D. --- Step: 1.5.1 (Add) Q.E.D. --- Step: 1.5.2 Q.E.D. --- Step: 1.5.3 Q.E.D. --- Step: 1.5.4 Q.E.D. --- Step: 1.6.1 (Mul) Q.E.D. --- Step: 1.6.2 Q.E.D. --- Step: 1.6.3 Q.E.D. --- Step: 1.6.4 Q.E.D. --- Step: 1.6.5 Q.E.D. --- Step: 1.7.1 (Let) Q.E.D. +-- Step: 1.1.1.1 (Var) Q.E.D. +-- Step: 1.1.1.2 Q.E.D. +-- Step: 1.1.1.3 Q.E.D. +-- Step: 1.1.1.4 Q.E.D. +-- Step: 1.1.1.5 Q.E.D. +-- Step: 1.1.2.1 (Var) Q.E.D. +-- Step: 1.1.2.2 Q.E.D. +-- Step: 1.1.2.3 Q.E.D. +-- Step: 1.1.2.4 Q.E.D. +-- Step: 1.1.2.5 Q.E.D. +-- Step: 1.1.Completeness Q.E.D. +-- Step: 1.2 (Con) Q.E.D. +-- Step: 1.3.1 (Sqr) Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.3.4 Q.E.D. +-- Step: 1.4 (Inc) Q.E.D. +-- Step: 1.5.1 (Add) Q.E.D. +-- Step: 1.5.2 Q.E.D. +-- Step: 1.5.3 Q.E.D. +-- Step: 1.5.4 Q.E.D. +-- Step: 1.6.1 (Mul) Q.E.D. +-- Step: 1.6.2 Q.E.D. +-- Step: 1.6.3 Q.E.D. +-- Step: 1.6.4 Q.E.D. +-- Step: 1.6.5 Q.E.D. +-- Step: 1.7.1 (Let) Q.E.D. -- Step: 1.7.2 (2 way case split) --- Step: 1.7.2.1.1 Q.E.D. --- Step: 1.7.2.1.2 (shadow) Q.E.D. --- Step: 1.7.2.1.3 Q.E.D. --- Step: 1.7.2.1.4 Q.E.D. --- Step: 1.7.2.1.5 Q.E.D. --- Step: 1.7.2.2.1 Q.E.D. --- Step: 1.7.2.2.2 (swap) Q.E.D. --- Step: 1.7.2.2.3 Q.E.D. --- Step: 1.7.2.2.4 Q.E.D. --- Step: 1.7.2.2.5 Q.E.D. --- Step: 1.7.2.2.6 Q.E.D. --- Step: 1.7.2.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.7.2.1.1 Q.E.D. +-- Step: 1.7.2.1.2 (shadow) Q.E.D. +-- Step: 1.7.2.1.3 Q.E.D. +-- Step: 1.7.2.1.4 Q.E.D. +-- Step: 1.7.2.1.5 Q.E.D. +-- Step: 1.7.2.2.1 Q.E.D. +-- Step: 1.7.2.2.2 (swap) Q.E.D. +-- Step: 1.7.2.2.3 Q.E.D. +-- Step: 1.7.2.2.4 Q.E.D. +-- Step: 1.7.2.2.5 Q.E.D. +-- Step: 1.7.2.2.6 Q.E.D. +-- Step: 1.7.2.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: exprSize, interpInEnv, sbv.lookup, subst -- [Proven] substCorrect :: Ɐe ∷ (Expr String Integer) → Ɐnm ∷ String → Ɐv ∷ Integer → Ɐenv ∷ [(String, Integer)] → Bool substCorrect :: TP (Proof (Forall "e" Exp -> Forall "nm" String -> Forall "v" Integer -> Forall "env" EL -> SBool)) @@ -967,130 +967,130 @@ -- | Simplification preserves semantics. -- -- >>> runTPWith cvc5 simpCorrect --- Lemma: sqrCong Q.E.D. --- Lemma: sqrHelper Q.E.D. --- Lemma: addHelper Q.E.D. --- Lemma: mulCongL Q.E.D. --- Lemma: mulCongR Q.E.D. --- Lemma: mulHelper Q.E.D. --- Lemma: letHelper Q.E.D. --- Lemma: substCorrect Q.E.D. +-- Lemma: sqrCong Q.E.D. +-- Lemma: sqrHelper Q.E.D. +-- Lemma: addHelper Q.E.D. +-- Lemma: mulCongL Q.E.D. +-- Lemma: mulCongR Q.E.D. +-- Lemma: mulHelper Q.E.D. +-- Lemma: letHelper Q.E.D. +-- Lemma: substCorrect Q.E.D. -- Lemma: simpCorrect -- Step: 1 (7 way case split) --- Step: 1.1.1 (Var) Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.1.3 Q.E.D. --- Step: 1.2.1 (Con) Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.3.1 (Sqr) Q.E.D. +-- Step: 1.1.1 (Var) Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.1.3 Q.E.D. +-- Step: 1.2.1 (Con) Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.3.1 (Sqr) Q.E.D. -- Step: 1.3.2 (2 way case split) --- Step: 1.3.2.1.1 Q.E.D. --- Step: 1.3.2.1.2 (Sqr Con) Q.E.D. --- Step: 1.3.2.1.3 Q.E.D. --- Step: 1.3.2.1.4 Q.E.D. --- Step: 1.3.2.1.5 Q.E.D. --- Step: 1.3.2.2.1 Q.E.D. --- Step: 1.3.2.2.2 (Sqr _) Q.E.D. --- Step: 1.3.2.Completeness Q.E.D. --- Step: 1.4.1 (Inc) Q.E.D. +-- Step: 1.3.2.1.1 Q.E.D. +-- Step: 1.3.2.1.2 (Sqr Con) Q.E.D. +-- Step: 1.3.2.1.3 Q.E.D. +-- Step: 1.3.2.1.4 Q.E.D. +-- Step: 1.3.2.1.5 Q.E.D. +-- Step: 1.3.2.2.1 Q.E.D. +-- Step: 1.3.2.2.2 (Sqr _) Q.E.D. +-- Step: 1.3.2.Completeness Q.E.D. +-- Step: 1.4.1 (Inc) Q.E.D. -- Step: 1.4.2 (2 way case split) --- Step: 1.4.2.1.1 Q.E.D. --- Step: 1.4.2.1.2 (Inc Con) Q.E.D. --- Step: 1.4.2.1.3 Q.E.D. --- Step: 1.4.2.2.1 Q.E.D. --- Step: 1.4.2.2.2 (Inc _) Q.E.D. --- Step: 1.4.2.Completeness Q.E.D. --- Step: 1.5.1 (Add) Q.E.D. +-- Step: 1.4.2.1.1 Q.E.D. +-- Step: 1.4.2.1.2 (Inc Con) Q.E.D. +-- Step: 1.4.2.1.3 Q.E.D. +-- Step: 1.4.2.2.1 Q.E.D. +-- Step: 1.4.2.2.2 (Inc _) Q.E.D. +-- Step: 1.4.2.Completeness Q.E.D. +-- Step: 1.5.1 (Add) Q.E.D. -- Step: 1.5.2 (6 way case split) --- Step: 1.5.2.1.1 Q.E.D. --- Step: 1.5.2.1.2 (Add 0+b) Q.E.D. --- Step: 1.5.2.1.3 Q.E.D. --- Step: 1.5.2.2.1 Q.E.D. --- Step: 1.5.2.2.2 (Add a+0) Q.E.D. --- Step: 1.5.2.2.3 Q.E.D. --- Step: 1.5.2.3.1 Q.E.D. --- Step: 1.5.2.3.2 (Add Con) Q.E.D. --- Step: 1.5.2.3.3 Q.E.D. +-- Step: 1.5.2.1.1 Q.E.D. +-- Step: 1.5.2.1.2 (Add 0+b) Q.E.D. +-- Step: 1.5.2.1.3 Q.E.D. +-- Step: 1.5.2.2.1 Q.E.D. +-- Step: 1.5.2.2.2 (Add a+0) Q.E.D. +-- Step: 1.5.2.2.3 Q.E.D. +-- Step: 1.5.2.3.1 Q.E.D. +-- Step: 1.5.2.3.2 (Add Con) Q.E.D. +-- Step: 1.5.2.3.3 Q.E.D. -- Step: 1.5.2.4 (2 way case split) --- Step: 1.5.2.4.1.1 Q.E.D. --- Step: 1.5.2.4.1.2 (Add 0,_) Q.E.D. --- Step: 1.5.2.4.1.3 Q.E.D. --- Step: 1.5.2.4.2.1 Q.E.D. --- Step: 1.5.2.4.2.2 (Add C,_) Q.E.D. --- Step: 1.5.2.4.Completeness Q.E.D. +-- Step: 1.5.2.4.1.1 Q.E.D. +-- Step: 1.5.2.4.1.2 (Add 0,_) Q.E.D. +-- Step: 1.5.2.4.1.3 Q.E.D. +-- Step: 1.5.2.4.2.1 Q.E.D. +-- Step: 1.5.2.4.2.2 (Add C,_) Q.E.D. +-- Step: 1.5.2.4.Completeness Q.E.D. -- Step: 1.5.2.5 (2 way case split) --- Step: 1.5.2.5.1.1 Q.E.D. --- Step: 1.5.2.5.1.2 (Add _,0) Q.E.D. --- Step: 1.5.2.5.1.3 Q.E.D. --- Step: 1.5.2.5.2.1 Q.E.D. --- Step: 1.5.2.5.2.2 (Add _,C) Q.E.D. --- Step: 1.5.2.5.Completeness Q.E.D. --- Step: 1.5.2.6.1 Q.E.D. --- Step: 1.5.2.6.2 (Add _,_) Q.E.D. --- Step: 1.5.2.Completeness Q.E.D. --- Step: 1.6.1 (Mul) Q.E.D. +-- Step: 1.5.2.5.1.1 Q.E.D. +-- Step: 1.5.2.5.1.2 (Add _,0) Q.E.D. +-- Step: 1.5.2.5.1.3 Q.E.D. +-- Step: 1.5.2.5.2.1 Q.E.D. +-- Step: 1.5.2.5.2.2 (Add _,C) Q.E.D. +-- Step: 1.5.2.5.Completeness Q.E.D. +-- Step: 1.5.2.6.1 Q.E.D. +-- Step: 1.5.2.6.2 (Add _,_) Q.E.D. +-- Step: 1.5.2.Completeness Q.E.D. +-- Step: 1.6.1 (Mul) Q.E.D. -- Step: 1.6.2 (8 way case split) --- Step: 1.6.2.1.1 Q.E.D. --- Step: 1.6.2.1.2 (Mul 0*b) Q.E.D. --- Step: 1.6.2.1.3 Q.E.D. --- Step: 1.6.2.2.1 Q.E.D. --- Step: 1.6.2.2.2 (Mul a*0) Q.E.D. --- Step: 1.6.2.2.3 Q.E.D. --- Step: 1.6.2.3.1 Q.E.D. --- Step: 1.6.2.3.2 (Mul 1*b) Q.E.D. --- Step: 1.6.2.3.3 Q.E.D. --- Step: 1.6.2.3.4 Q.E.D. --- Step: 1.6.2.3.5 Q.E.D. --- Step: 1.6.2.4.1 Q.E.D. --- Step: 1.6.2.4.2 (Mul a*1) Q.E.D. --- Step: 1.6.2.4.3 Q.E.D. --- Step: 1.6.2.4.4 Q.E.D. --- Step: 1.6.2.4.5 Q.E.D. --- Step: 1.6.2.5.1 Q.E.D. --- Step: 1.6.2.5.2 (Mul Con) Q.E.D. --- Step: 1.6.2.5.3 Q.E.D. --- Step: 1.6.2.5.4 Q.E.D. --- Step: 1.6.2.5.5 Q.E.D. --- Step: 1.6.2.5.6 Q.E.D. +-- Step: 1.6.2.1.1 Q.E.D. +-- Step: 1.6.2.1.2 (Mul 0*b) Q.E.D. +-- Step: 1.6.2.1.3 Q.E.D. +-- Step: 1.6.2.2.1 Q.E.D. +-- Step: 1.6.2.2.2 (Mul a*0) Q.E.D. +-- Step: 1.6.2.2.3 Q.E.D. +-- Step: 1.6.2.3.1 Q.E.D. +-- Step: 1.6.2.3.2 (Mul 1*b) Q.E.D. +-- Step: 1.6.2.3.3 Q.E.D. +-- Step: 1.6.2.3.4 Q.E.D. +-- Step: 1.6.2.3.5 Q.E.D. +-- Step: 1.6.2.4.1 Q.E.D. +-- Step: 1.6.2.4.2 (Mul a*1) Q.E.D. +-- Step: 1.6.2.4.3 Q.E.D. +-- Step: 1.6.2.4.4 Q.E.D. +-- Step: 1.6.2.4.5 Q.E.D. +-- Step: 1.6.2.5.1 Q.E.D. +-- Step: 1.6.2.5.2 (Mul Con) Q.E.D. +-- Step: 1.6.2.5.3 Q.E.D. +-- Step: 1.6.2.5.4 Q.E.D. +-- Step: 1.6.2.5.5 Q.E.D. +-- Step: 1.6.2.5.6 Q.E.D. -- Step: 1.6.2.6 (3 way case split) --- Step: 1.6.2.6.1.1 Q.E.D. --- Step: 1.6.2.6.1.2 (Mul 0,_) Q.E.D. --- Step: 1.6.2.6.1.3 Q.E.D. --- Step: 1.6.2.6.2.1 Q.E.D. --- Step: 1.6.2.6.2.2 (Mul 1,_) Q.E.D. --- Step: 1.6.2.6.2.3 Q.E.D. --- Step: 1.6.2.6.2.4 Q.E.D. --- Step: 1.6.2.6.2.5 Q.E.D. --- Step: 1.6.2.6.3.1 Q.E.D. --- Step: 1.6.2.6.3.2 (Mul C,_) Q.E.D. --- Step: 1.6.2.6.Completeness Q.E.D. +-- Step: 1.6.2.6.1.1 Q.E.D. +-- Step: 1.6.2.6.1.2 (Mul 0,_) Q.E.D. +-- Step: 1.6.2.6.1.3 Q.E.D. +-- Step: 1.6.2.6.2.1 Q.E.D. +-- Step: 1.6.2.6.2.2 (Mul 1,_) Q.E.D. +-- Step: 1.6.2.6.2.3 Q.E.D. +-- Step: 1.6.2.6.2.4 Q.E.D. +-- Step: 1.6.2.6.2.5 Q.E.D. +-- Step: 1.6.2.6.3.1 Q.E.D. +-- Step: 1.6.2.6.3.2 (Mul C,_) Q.E.D. +-- Step: 1.6.2.6.Completeness Q.E.D. -- Step: 1.6.2.7 (3 way case split) --- Step: 1.6.2.7.1.1 Q.E.D. --- Step: 1.6.2.7.1.2 (Mul _,0) Q.E.D. --- Step: 1.6.2.7.1.3 Q.E.D. --- Step: 1.6.2.7.2.1 Q.E.D. --- Step: 1.6.2.7.2.2 (Mul _,1) Q.E.D. --- Step: 1.6.2.7.2.3 Q.E.D. --- Step: 1.6.2.7.2.4 Q.E.D. --- Step: 1.6.2.7.2.5 Q.E.D. --- Step: 1.6.2.7.3.1 Q.E.D. --- Step: 1.6.2.7.3.2 (Mul _,C) Q.E.D. --- Step: 1.6.2.7.Completeness Q.E.D. --- Step: 1.6.2.8.1 Q.E.D. --- Step: 1.6.2.8.2 (Mul _,_) Q.E.D. --- Step: 1.6.2.Completeness Q.E.D. --- Step: 1.7.1 (Let) Q.E.D. +-- Step: 1.6.2.7.1.1 Q.E.D. +-- Step: 1.6.2.7.1.2 (Mul _,0) Q.E.D. +-- Step: 1.6.2.7.1.3 Q.E.D. +-- Step: 1.6.2.7.2.1 Q.E.D. +-- Step: 1.6.2.7.2.2 (Mul _,1) Q.E.D. +-- Step: 1.6.2.7.2.3 Q.E.D. +-- Step: 1.6.2.7.2.4 Q.E.D. +-- Step: 1.6.2.7.2.5 Q.E.D. +-- Step: 1.6.2.7.3.1 Q.E.D. +-- Step: 1.6.2.7.3.2 (Mul _,C) Q.E.D. +-- Step: 1.6.2.7.Completeness Q.E.D. +-- Step: 1.6.2.8.1 Q.E.D. +-- Step: 1.6.2.8.2 (Mul _,_) Q.E.D. +-- Step: 1.6.2.Completeness Q.E.D. +-- Step: 1.7.1 (Let) Q.E.D. -- Step: 1.7.2 (2 way case split) --- Step: 1.7.2.1.1 Q.E.D. --- Step: 1.7.2.1.2 (Let Con) Q.E.D. --- Step: 1.7.2.1.3 Q.E.D. --- Step: 1.7.2.1.4 Q.E.D. --- Step: 1.7.2.2.1 Q.E.D. --- Step: 1.7.2.2.2 (Let _) Q.E.D. --- Step: 1.7.2.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.7.2.1.1 Q.E.D. +-- Step: 1.7.2.1.2 (Let Con) Q.E.D. +-- Step: 1.7.2.1.3 Q.E.D. +-- Step: 1.7.2.1.4 Q.E.D. +-- Step: 1.7.2.2.1 Q.E.D. +-- Step: 1.7.2.2.2 (Let _) Q.E.D. +-- Step: 1.7.2.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: exprSize, interpInEnv, sbv.lookup, simplify, subst -- [Proven] simpCorrect :: Ɐe ∷ (Expr String Integer) → Ɐenv ∷ [(String, Integer)] → Bool simpCorrect :: TP (Proof (Forall "e" Exp -> Forall "env" EL -> SBool)) @@ -1369,54 +1369,54 @@ -- is the same as constant-folding it first and then interpreting the result. -- -- >>> runTPWith cvc5 cfoldCorrect --- Lemma: measureNonNeg Q.E.D. --- Lemma: simpCorrect Q.E.D. --- Cached: sqrCong Q.E.D. --- Cached: sqrHelper Q.E.D. --- Cached: mulCongL Q.E.D. --- Cached: mulCongR Q.E.D. --- Cached: mulHelper Q.E.D. +-- Lemma: measureNonNeg Q.E.D. +-- Lemma: simpCorrect Q.E.D. +-- Lemma: sqrCong Q.E.D. [Cached] +-- Lemma: sqrHelper Q.E.D. [Cached] +-- Lemma: mulCongL Q.E.D. [Cached] +-- Lemma: mulCongR Q.E.D. [Cached] +-- Lemma: mulHelper Q.E.D. [Cached] -- Inductive lemma (strong): cfoldCorrect --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split) --- Step: 1.1.1 (case Var) Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.1.3 Q.E.D. --- Step: 1.2.1 (case Con) Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.3.1 (case Sqr) Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.3.4 Q.E.D. --- Step: 1.3.5 Q.E.D. --- Step: 1.3.6 Q.E.D. --- Step: 1.3.7 Q.E.D. --- Step: 1.4.1 (case Inc) Q.E.D. --- Step: 1.4.2 Q.E.D. --- Step: 1.4.3 Q.E.D. --- Step: 1.4.4 Q.E.D. --- Step: 1.4.5 Q.E.D. --- Step: 1.5.1 (case Add) Q.E.D. --- Step: 1.5.2 Q.E.D. --- Step: 1.5.3 Q.E.D. --- Step: 1.5.4 Q.E.D. --- Step: 1.5.5 Q.E.D. --- Step: 1.6.1 (case Mul) Q.E.D. --- Step: 1.6.2 Q.E.D. --- Step: 1.6.3 Q.E.D. --- Step: 1.6.4 Q.E.D. --- Step: 1.6.5 Q.E.D. --- Step: 1.6.6 Q.E.D. --- Step: 1.6.7 Q.E.D. --- Step: 1.6.8 Q.E.D. --- Step: 1.7.1 (case Let) Q.E.D. --- Step: 1.7.2 Q.E.D. --- Step: 1.7.3 Q.E.D. --- Step: 1.7.4 Q.E.D. --- Step: 1.7.5 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 (case Var) Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.1.3 Q.E.D. +-- Step: 1.2.1 (case Con) Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.3.1 (case Sqr) Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.3.4 Q.E.D. +-- Step: 1.3.5 Q.E.D. +-- Step: 1.3.6 Q.E.D. +-- Step: 1.3.7 Q.E.D. +-- Step: 1.4.1 (case Inc) Q.E.D. +-- Step: 1.4.2 Q.E.D. +-- Step: 1.4.3 Q.E.D. +-- Step: 1.4.4 Q.E.D. +-- Step: 1.4.5 Q.E.D. +-- Step: 1.5.1 (case Add) Q.E.D. +-- Step: 1.5.2 Q.E.D. +-- Step: 1.5.3 Q.E.D. +-- Step: 1.5.4 Q.E.D. +-- Step: 1.5.5 Q.E.D. +-- Step: 1.6.1 (case Mul) Q.E.D. +-- Step: 1.6.2 Q.E.D. +-- Step: 1.6.3 Q.E.D. +-- Step: 1.6.4 Q.E.D. +-- Step: 1.6.5 Q.E.D. +-- Step: 1.6.6 Q.E.D. +-- Step: 1.6.7 Q.E.D. +-- Step: 1.6.8 Q.E.D. +-- Step: 1.7.1 (case Let) Q.E.D. +-- Step: 1.7.2 Q.E.D. +-- Step: 1.7.3 Q.E.D. +-- Step: 1.7.4 Q.E.D. +-- Step: 1.7.5 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: cfold, exprSize, interpInEnv, sbv.lookup, simplify, subst -- [Proven] cfoldCorrect :: Ɐe ∷ (Expr String Integer) → Ɐenv ∷ [(String, Integer)] → Bool cfoldCorrect :: TP (Proof (Forall "e" Exp -> Forall "env" EL -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Countdown.hs b/Documentation/SBV/Examples/TP/Countdown.hs --- a/Documentation/SBV/Examples/TP/Countdown.hs +++ b/Documentation/SBV/Examples/TP/Countdown.hs @@ -47,7 +47,7 @@ -- | Prove that @countdown n@ always starts with @n@, for positive @n@. -- -- >>> runTP countdownHead --- Lemma: countdownHead Q.E.D. +-- Lemma: countdownHead Q.E.D. -- Functions proven terminating: countdown -- [Proven] countdownHead :: Ɐn ∷ Integer → Bool countdownHead :: TP (Proof (Forall "n" Integer -> SBool)) @@ -57,10 +57,10 @@ -- -- >>> runTP countdownNonEmpty -- Inductive lemma: countdownNonEmpty --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: countdown -- [Proven] countdownNonEmpty :: Ɐn ∷ Integer → Bool countdownNonEmpty :: TP (Proof (Forall "n" Integer -> SBool)) @@ -77,11 +77,11 @@ -- -- >>> runTP countdownLen -- Inductive lemma: countdownLen --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: countdown -- [Proven] countdownLen :: Ɐn ∷ Integer → Bool countdownLen :: TP (Proof (Forall "n" Integer -> SBool)) @@ -105,13 +105,13 @@ -- covers the entire domain of the goal. -- -- >>> runTP countdownElem --- Lemma: countdownLen Q.E.D. --- Lemma: elemOne Q.E.D. +-- Lemma: countdownLen Q.E.D. +-- Lemma: elemOne Q.E.D. -- Inductive lemma: countdownElem --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: countdown -- [Proven] countdownElem :: Ɐn ∷ Integer → Ɐk ∷ Integer → Bool countdownElem :: TP (Proof (Forall "n" Integer -> Forall "k" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Fibonacci.hs b/Documentation/SBV/Examples/TP/Fibonacci.hs --- a/Documentation/SBV/Examples/TP/Fibonacci.hs +++ b/Documentation/SBV/Examples/TP/Fibonacci.hs @@ -51,15 +51,15 @@ -- -- >>> correctness -- Inductive lemma: helper --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 (unfold fibonacci) Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 (unfold fibonacci) Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: fibCorrect --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: fib, fibonacci -- [Proven] fibCorrect :: Ɐn ∷ Integer → Bool correctness :: IO (Proof (Forall "n" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/GCD.hs b/Documentation/SBV/Examples/TP/GCD.hs --- a/Documentation/SBV/Examples/TP/GCD.hs +++ b/Documentation/SBV/Examples/TP/GCD.hs @@ -62,14 +62,14 @@ -- ==== __Proof__ -- >>> runTP gcdNonNegative -- Inductive lemma (strong): nonNegativeNGCD --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: nonNegative Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: nonNegative Q.E.D. -- Functions proven terminating: nGCD -- [Proven] nonNegative :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdNonNegative :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -96,14 +96,14 @@ -- ==== __Proof__ -- >>> runTP gcdZero -- Inductive lemma (strong): nGCDZero --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: gcdZero Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: gcdZero Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdZero :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdZero :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -124,7 +124,7 @@ ] lemma "gcdZero" - (\(Forall @"a" a) (Forall @"b" b) -> gcd a b .== 0 .=> a .== 0 .&& b .== 0) + (\(Forall @"a" a) (Forall @"b" b) -> gcd a b .== 0 .=> a .== 0 .&& b .== 0) [proofOf nGCDZero] -- | \(\gcd\, a\ b=\gcd\, b\ a\) @@ -132,12 +132,12 @@ -- ==== __Proof__ -- >>> runTP commutative -- Lemma: nGCDCommutative --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Lemma: commutative --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] commutative :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool commutative :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -166,7 +166,7 @@ -- -- ==== __Proof__ -- >>> runTP negGCD --- Lemma: negGCD Q.E.D. +-- Lemma: negGCD Q.E.D. -- Functions proven terminating: nGCD -- [Proven] negGCD :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool negGCD :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -176,7 +176,7 @@ -- -- ==== __Proof__ -- >>> runTP zeroGCD --- Lemma: negGCD Q.E.D. +-- Lemma: negGCD Q.E.D. -- Functions proven terminating: nGCD -- [Proven] negGCD :: Ɐa ∷ Integer → Bool zeroGCD :: TP (Proof (Forall "a" Integer -> SBool)) @@ -204,11 +204,11 @@ -- >>> runTP dvdMul -- Lemma: dvdMul -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- [Proven] dvdMul :: Ɐd ∷ Integer → Ɐa ∷ Integer → Ɐk ∷ Integer → Bool dvdMul :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> Forall "k" Integer -> SBool)) dvdMul = calc "dvdMul" @@ -234,20 +234,20 @@ -- -- ==== __Proof__ -- >>> runTP dvdAbs --- Lemma: dvdMul Q.E.D. +-- Lemma: dvdMul Q.E.D. -- Lemma: dvdAbs_l2r -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: dvdAbs_r2l -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: dvdAbs Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: dvdAbs Q.E.D. -- [Proven] dvdAbs :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool dvdAbs :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) dvdAbs = do @@ -287,11 +287,11 @@ -- >>> runTP dvdOddThenOdd -- Lemma: dvdOddThenOdd -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- [Proven] dvdOddThenOdd :: Ɐd ∷ Integer → Ɐa ∷ Integer → Bool dvdOddThenOdd :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> SBool)) dvdOddThenOdd = calc "dvdOddThenOdd" @@ -308,14 +308,14 @@ -- ==== __Proof__ -- >>> runTP dvdEvenWhenOdd -- Lemma: dvdEvenWhenOdd --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Result: Q.E.D. -- [Proven] dvdEvenWhenOdd :: Ɐd ∷ Integer → Ɐa ∷ Integer → Bool dvdEvenWhenOdd :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> SBool)) dvdEvenWhenOdd = calc "dvdEvenWhenOdd" @@ -357,12 +357,12 @@ -- >>> runTP dvdSum1 -- Lemma: dvdSum1 -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- [Proven] dvdSum1 :: Ɐd ∷ Integer → Ɐa ∷ Integer → Ɐb ∷ Integer → Bool dvdSum1 :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> Forall "b" Integer -> SBool)) dvdSum1 = @@ -383,12 +383,12 @@ -- >>> runTP dvdSum2 -- Lemma: dvdSum2 -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- [Proven] dvdSum2 :: Ɐd ∷ Integer → Ɐa ∷ Integer → Ɐb ∷ Integer → Bool dvdSum2 :: TP (Proof (Forall "d" Integer -> Forall "a" Integer -> Forall "b" Integer -> SBool)) dvdSum2 = @@ -414,19 +414,19 @@ -- -- ==== __Proof__ -- >>> runTP gcdDivides --- Lemma: dvdAbs Q.E.D. +-- Lemma: dvdAbs Q.E.D. -- Lemma: helper --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): dvdNGCD --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: gcdDivides Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: gcdDivides Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdDivides :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdDivides :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -474,32 +474,32 @@ -- -- ==== __Proof__ -- >>> runTP gcdMaximal --- Lemma: dvdAbs Q.E.D. --- Lemma: commutative Q.E.D. --- Lemma: eDiv Q.E.D. +-- Lemma: dvdAbs Q.E.D. +-- Lemma: commutative Q.E.D. +-- Lemma: eDiv Q.E.D. -- Lemma: helper --- Step: 1 (x `dvd` a && x `dvd` b) Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 (x `dvd` a && x `dvd` b) Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): mNGCD --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: gcdMaximal -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdMaximal :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐx ∷ Integer → Bool gcdMaximal :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "x" Integer -> SBool)) @@ -574,12 +574,12 @@ -- -- ==== __Proof__ -- >>> runTP gcdCorrect --- Lemma: gcdDivides Q.E.D. --- Lemma: gcdMaximal Q.E.D. +-- Lemma: gcdDivides Q.E.D. +-- Lemma: gcdMaximal Q.E.D. -- Lemma: gcdCorrect --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdCorrect :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdCorrect :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -613,13 +613,13 @@ -- -- ==== __Proof__ -- >>> runTP gcdLargest --- Lemma: gcdMaximal Q.E.D. --- Lemma: gcdZero Q.E.D. --- Lemma: nonNegative Q.E.D. +-- Lemma: gcdMaximal Q.E.D. +-- Lemma: gcdZero Q.E.D. +-- Lemma: nonNegative Q.E.D. -- Lemma: gcdLargest --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdLargest :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐx ∷ Integer → Bool gcdLargest :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "x" Integer -> SBool)) @@ -645,19 +645,19 @@ -- -- ==== __Proof__ -- >>> runTP gcdAdd --- Lemma: dvdSum1 Q.E.D. --- Lemma: dvdSum2 Q.E.D. --- Lemma: gcdDivides Q.E.D. --- Lemma: gcdLargest Q.E.D. +-- Lemma: dvdSum1 Q.E.D. +-- Lemma: dvdSum2 Q.E.D. +-- Lemma: gcdDivides Q.E.D. +-- Lemma: gcdLargest Q.E.D. -- Lemma: gcdAdd --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdAdd :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdAdd :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -706,28 +706,28 @@ -- -- ==== __Proof__ -- >>> runTP gcdEvenEven --- Lemma: red2 Q.E.D. +-- Lemma: red2 Q.E.D. -- Lemma: modEE --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): nGCDEvenEven --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: gcdEvenEven --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdEvenEven :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdEvenEven :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -776,21 +776,21 @@ -- -- ==== __Proof__ -- >>> runTP gcdOddEven --- Lemma: gcdDivides Q.E.D. --- Lemma: gcdLargest Q.E.D. --- Cached: dvdMul Q.E.D. --- Lemma: dvdOddThenOdd Q.E.D. --- Lemma: dvdEvenWhenOdd Q.E.D. +-- Lemma: gcdDivides Q.E.D. +-- Lemma: gcdLargest Q.E.D. +-- Lemma: dvdMul Q.E.D. [Cached] +-- Lemma: dvdOddThenOdd Q.E.D. +-- Lemma: dvdEvenWhenOdd Q.E.D. -- Lemma: gcdOddEven --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Step: 8 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Step: 8 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: nGCD -- [Proven] gcdOddEven :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdOddEven :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -866,29 +866,29 @@ -- -- ==== __Proof__ -- >>> runTP gcdSubEquiv --- Lemma: commutative Q.E.D. --- Lemma: gcdAdd Q.E.D. +-- Lemma: commutative Q.E.D. +-- Lemma: gcdAdd Q.E.D. -- Inductive lemma (strong): nGCDSubEquiv --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (5 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. --- Step: 1.4.1 Q.E.D. --- Step: 1.4.2 Q.E.D. --- Step: 1.4.3 Q.E.D. --- Step: 1.5.1 Q.E.D. --- Step: 1.5.2 Q.E.D. --- Step: 1.5.3 Q.E.D. --- Step: 1.5.4 Q.E.D. --- Step: 1.5.5 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. +-- Step: 1.4.1 Q.E.D. +-- Step: 1.4.2 Q.E.D. +-- Step: 1.4.3 Q.E.D. +-- Step: 1.5.1 Q.E.D. +-- Step: 1.5.2 Q.E.D. +-- Step: 1.5.3 Q.E.D. +-- Step: 1.5.4 Q.E.D. +-- Step: 1.5.5 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: gcdSubEquiv --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: nGCD, nGCDSub -- [Proven] gcdSubEquiv :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdSubEquiv :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) @@ -959,41 +959,41 @@ -- -- ==== __Proof__ -- >>> runTP gcdBinEquiv --- Lemma: gcdEvenEven Q.E.D. --- Lemma: gcdOddEven Q.E.D. --- Lemma: gcdAdd Q.E.D. --- Cached: commutative Q.E.D. +-- Lemma: gcdEvenEven Q.E.D. +-- Lemma: gcdOddEven Q.E.D. +-- Lemma: gcdAdd Q.E.D. +-- Lemma: commutative Q.E.D. [Cached] -- Inductive lemma (strong): nGCDBinEquiv --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (5 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.4.1 Q.E.D. --- Step: 1.4.2 Q.E.D. --- Step: 1.4.3 Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.4.1 Q.E.D. +-- Step: 1.4.2 Q.E.D. +-- Step: 1.4.3 Q.E.D. -- Step: 1.5 (3 way case split) --- Step: 1.5.1 Q.E.D. --- Step: 1.5.2.1 Q.E.D. --- Step: 1.5.2.2 Q.E.D. --- Step: 1.5.2.3 Q.E.D. --- Step: 1.5.2.4 Q.E.D. --- Step: 1.5.2.5 Q.E.D. --- Step: 1.5.2.6 Q.E.D. --- Step: 1.5.3.1 Q.E.D. --- Step: 1.5.3.2 Q.E.D. --- Step: 1.5.3.3 Q.E.D. --- Step: 1.5.3.4 Q.E.D. --- Step: 1.5.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.5.1 Q.E.D. +-- Step: 1.5.2.1 Q.E.D. +-- Step: 1.5.2.2 Q.E.D. +-- Step: 1.5.2.3 Q.E.D. +-- Step: 1.5.2.4 Q.E.D. +-- Step: 1.5.2.5 Q.E.D. +-- Step: 1.5.2.6 Q.E.D. +-- Step: 1.5.3.1 Q.E.D. +-- Step: 1.5.3.2 Q.E.D. +-- Step: 1.5.3.3 Q.E.D. +-- Step: 1.5.3.4 Q.E.D. +-- Step: 1.5.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: gcdBinEquiv --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: nGCD, nGCDBin -- [Proven] gcdBinEquiv :: Ɐa ∷ Integer → Ɐb ∷ Integer → Bool gcdBinEquiv :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/InsertionSort.hs b/Documentation/SBV/Examples/TP/InsertionSort.hs --- a/Documentation/SBV/Examples/TP/InsertionSort.hs +++ b/Documentation/SBV/Examples/TP/InsertionSort.hs @@ -80,49 +80,49 @@ -- We have: -- -- >>> correctness @Integer --- Lemma: nonDecrTail Q.E.D. +-- Lemma: nonDecrTail Q.E.D. -- Inductive lemma: insertNonDecreasing --- Step: Base Q.E.D. --- Step: 1 (unfold insert) Q.E.D. --- Step: 2 (push nonDecreasing down) Q.E.D. --- Step: 3 (unfold simplify) Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 (unfold insert) Q.E.D. +-- Step: 2 (push nonDecreasing down) Q.E.D. +-- Step: 3 (unfold simplify) Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: sortNonDecreasing --- Step: Base Q.E.D. --- Step: 1 (unfold insertionSort) Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 (unfold insertionSort) Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: insertIsElem --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: removeAfterInsert --- Step: Base Q.E.D. --- Step: 1 (expand insert) Q.E.D. --- Step: 2 (push removeFirst down ite) Q.E.D. --- Step: 3 (unfold removeFirst on 'then') Q.E.D. --- Step: 4 (unfold removeFirst on 'else') Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 (simplify) Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 (expand insert) Q.E.D. +-- Step: 2 (push removeFirst down ite) Q.E.D. +-- Step: 3 (unfold removeFirst on 'then') Q.E.D. +-- Step: 4 (unfold removeFirst on 'else') Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 (simplify) Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: sortIsPermutation --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. --- Lemma: insertionSortIsCorrect Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. +-- Lemma: insertionSortIsCorrect Q.E.D. -- Functions proven terminating: insert, insertionSort, isPermutation, nonDecreasing, removeFirst -- [Proven] insertionSortIsCorrect :: Ɐxs ∷ [Integer] → Bool correctness :: forall a. (OrdSymbolic (SBV a), Eq a, SymVal a) => IO (Proof (Forall "xs" [a] -> SBool)) -correctness = runTPWith (tpRibbon 45 cvc5) $ do +correctness = runTPWith cvc5 $ do -------------------------------------------------------------------------------------------- -- Part I. Import helper lemmas, definitions diff --git a/Documentation/SBV/Examples/TP/Kadane.hs b/Documentation/SBV/Examples/TP/Kadane.hs --- a/Documentation/SBV/Examples/TP/Kadane.hs +++ b/Documentation/SBV/Examples/TP/Kadane.hs @@ -129,16 +129,16 @@ -- -- >>> runTPWith cvc5 correctness -- Inductive lemma: kadaneHelperInvariant --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Lemma: correctness --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: kadaneHelper, mss, mssBegin -- [Proven] correctness :: Ɐxs ∷ [Integer] → Bool correctness :: TP (Proof (Forall "xs" [Integer] -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Kleene.hs b/Documentation/SBV/Examples/TP/Kleene.hs --- a/Documentation/SBV/Examples/TP/Kleene.hs +++ b/Documentation/SBV/Examples/TP/Kleene.hs @@ -69,20 +69,20 @@ -- Axiom: ldistrib -- Axiom: unfold -- Axiom: least_fix --- Lemma: par_lzero Q.E.D. --- Lemma: par_monotone Q.E.D. --- Lemma: seq_monotone Q.E.D. +-- Lemma: par_lzero Q.E.D. +-- Lemma: par_monotone Q.E.D. +-- Lemma: seq_monotone Q.E.D. -- Lemma: star_star_1 --- Step: 1 (unfold) Q.E.D. --- Step: 2 (factor out x * star x) Q.E.D. --- Step: 3 (par_idem) Q.E.D. --- Step: 4 (unfold) Q.E.D. --- Result: Q.E.D. --- Lemma: subset_eq Q.E.D. --- Lemma: star_star_2_2 Q.E.D. --- Lemma: star_star_2_3 Q.E.D. --- Lemma: star_star_2_1 Q.E.D. --- Lemma: star_star_2 Q.E.D. +-- Step: 1 (unfold) Q.E.D. +-- Step: 2 (factor out x * star x) Q.E.D. +-- Step: 3 (par_idem) Q.E.D. +-- Step: 4 (unfold) Q.E.D. +-- Result: Q.E.D. +-- Lemma: subset_eq Q.E.D. +-- Lemma: star_star_2_2 Q.E.D. +-- Lemma: star_star_2_3 Q.E.D. +-- Lemma: star_star_2_1 Q.E.D. +-- Lemma: star_star_2 Q.E.D. kleeneProofs :: IO () kleeneProofs = runTP $ do diff --git a/Documentation/SBV/Examples/TP/Lists.hs b/Documentation/SBV/Examples/TP/Lists.hs --- a/Documentation/SBV/Examples/TP/Lists.hs +++ b/Documentation/SBV/Examples/TP/Lists.hs @@ -95,7 +95,7 @@ -- | @xs ++ [] == xs@ -- -- >>> runTP $ appendNull @Integer --- Lemma: appendNull Q.E.D. +-- Lemma: appendNull Q.E.D. -- [Proven] appendNull :: Ɐxs ∷ [Integer] → Bool appendNull :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool)) appendNull = lemma "appendNull" @@ -105,7 +105,7 @@ -- | @(x : xs) ++ ys == x : (xs ++ ys)@ -- -- >>> runTP $ consApp @Integer --- Lemma: consApp Q.E.D. +-- Lemma: consApp Q.E.D. -- [Proven] consApp :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool consApp :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> Forall "ys" [a] -> SBool)) consApp = lemma "consApp" @@ -115,7 +115,7 @@ -- | @(xs ++ ys) ++ zs == xs ++ (ys ++ zs)@ -- -- >>> runTP $ appendAssoc @Integer --- Lemma: appendAssoc Q.E.D. +-- Lemma: appendAssoc Q.E.D. -- [Proven] appendAssoc :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐzs ∷ [Integer] → Bool -- -- Surprisingly, z3 can prove this without any induction. (Since SBV's append translates directly to @@ -131,9 +131,9 @@ -- -- >>> runTP $ initsLength @Integer -- Inductive lemma (strong): initsLength --- Step: Measure is non-negative Q.E.D. --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: Measure is non-negative Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.inits -- [Proven] initsLength :: Ɐxs ∷ [Integer] → Bool initsLength :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool)) @@ -150,12 +150,12 @@ -- -- >>> runTP $ tailsLength @Integer -- Inductive lemma: tailsLength --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.tails -- [Proven] tailsLength :: Ɐxs ∷ [Integer] → Bool tailsLength :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool)) @@ -180,22 +180,22 @@ -- -- >>> runTPWith cvc5 $ tailsAppend @Integer -- Inductive lemma: base case --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: helper --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: tailsAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.closureMap, sbv.tails -- [Proven] tailsAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool tailsAppend :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) @@ -247,12 +247,12 @@ -- -- >>> runTP $ revLen @Integer -- Inductive lemma: revLen --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revLen :: Ɐxs ∷ [Integer] → Bool revLen :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool)) @@ -270,13 +270,13 @@ -- -- >>> runTP $ revApp @Integer -- Inductive lemma: revApp --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revApp :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool revApp :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) @@ -294,7 +294,7 @@ -- | @reverse (x:xs) == reverse xs ++ [x]@ -- -- >>> runTP $ revCons @Integer --- Lemma: revCons Q.E.D. +-- Lemma: revCons Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revCons :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool revCons :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool)) @@ -306,14 +306,14 @@ -- -- >>> runTP $ revSnoc @Integer -- Inductive lemma: revApp --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. --- Lemma: revSnoc Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. +-- Lemma: revSnoc Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revSnoc :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool revSnoc :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool)) @@ -328,20 +328,20 @@ -- -- >>> runTP $ revRev @Integer -- Inductive lemma: revApp --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: revRev --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.reverse -- [Proven] revRev :: Ɐxs ∷ [Integer] → Bool revRev :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool)) @@ -366,15 +366,15 @@ -- -- >>> runTP enumLen -- Inductive lemma (strong): enumLen --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up -- [Proven] enumLen :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool enumLen :: TP (Proof (Forall "n" Integer -> Forall "m" Integer -> SBool)) @@ -398,21 +398,21 @@ -- -- >>> runTP $ revNM -- Inductive lemma (strong): helper --- Step: Measure is non-negative Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Measure is non-negative Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): revNM --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, sbv.reverse -- [Proven] revNM :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool @@ -447,7 +447,7 @@ -- | @length (x : xs) == 1 + length xs@ -- -- >>> runTP $ lengthTail @Integer --- Lemma: lengthTail Q.E.D. +-- Lemma: lengthTail Q.E.D. -- [Proven] lengthTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool lengthTail :: forall a. SymVal a => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool)) lengthTail = lemma "lengthTail" @@ -457,7 +457,7 @@ -- | @length (xs ++ ys) == length xs + length ys@ -- -- >>> runTP $ lenAppend @Integer --- Lemma: lenAppend Q.E.D. +-- Lemma: lenAppend Q.E.D. -- [Proven] lenAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool lenAppend :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) lenAppend = lemma "lenAppend" @@ -467,7 +467,7 @@ -- | @length xs == length ys -> length (xs ++ ys) == 2 * length xs@ -- -- >>> runTP $ lenAppend2 @Integer --- Lemma: lenAppend2 Q.E.D. +-- Lemma: lenAppend2 Q.E.D. -- [Proven] lenAppend2 :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool lenAppend2 :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) lenAppend2 = lemma "lenAppend2" @@ -478,15 +478,15 @@ -- -- >>> runTP $ replicateLength @Integer -- Inductive lemma: replicateLength --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.replicate -- [Proven] replicateLength :: Ɐk ∷ Integer → Ɐx ∷ Integer → Bool replicateLength :: forall a. SymVal a => TP (Proof (Forall "k" Integer -> Forall "x" a -> SBool)) @@ -508,12 +508,12 @@ -- -- >>> runTP allAny -- Inductive lemma: allAny --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr -- [Proven] allAny :: Ɐxs ∷ [Bool] → Bool allAny :: TP (Proof (Forall "xs" [Bool] -> SBool)) @@ -531,12 +531,12 @@ -- -- >>> runTP $ mapEquiv @Integer @Integer (uninterpret "f") (uninterpret "g") -- Inductive lemma: mapEquiv --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] mapEquiv :: Ɐxs ∷ [Integer] → Bool mapEquiv :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> (SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -558,13 +558,13 @@ -- -- >>> runTP $ mapAppend @Integer @Integer (uninterpret "f") -- Inductive lemma: mapAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] mapAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool mapAppend :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) @@ -584,22 +584,22 @@ -- -- >>> runTP $ mapReverse @Integer @String (uninterpret "f") -- Inductive lemma: mapAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: mapReverse --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.reverse -- [Proven] mapReverse :: Ɐxs ∷ [Integer] → Bool mapReverse :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -623,13 +623,13 @@ -- -- >>> runTP $ mapCompose @Integer @Bool @String (uninterpret "f") (uninterpret "g") -- Inductive lemma: mapCompose --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] mapCompose :: Ɐxs ∷ [Integer] → Bool mapCompose :: forall a b c. (SymVal a, SymVal b, SymVal c) => (SBV a -> SBV b) -> (SBV b -> SBV c) -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -648,15 +648,15 @@ -- | @map f . concat = concat . map (map f)@ -- -- >>> runTP $ mapConcat @Integer @Bool (uninterpret "f") --- Lemma: mapAppend Q.E.D. +-- Lemma: mapAppend Q.E.D. -- Inductive lemma: mapConcat --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.map -- [Proven] mapConcat :: Ɐxs ∷ [[Integer]] → Bool mapConcat :: (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "xs" [[a]] -> SBool)) @@ -679,12 +679,12 @@ -- -- >>> runTP $ foldrMapFusion @String @Bool @Integer (uninterpret "a") (uninterpret "b") (uninterpret "c") -- Inductive lemma: foldrMapFusion --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.map -- [Proven] foldrMapFusion :: Ɐxs ∷ [String] → Bool foldrMapFusion :: forall a b c. (SymVal a, SymVal b, SymVal c) => SBV c -> (SBV a -> SBV b) -> (SBV b -> SBV c -> SBV c) -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -708,12 +708,12 @@ -- -- >>> runTP $ foldrFusion @String @Bool @Integer (uninterpret "a") (uninterpret "b") (uninterpret "f") (uninterpret "g") (uninterpret "h") -- Inductive lemma: foldrFusion --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr -- [Proven] foldrFusion :: Ɐxs ∷ [String] → Bool foldrFusion :: forall a b c. (SymVal a, SymVal b, SymVal c) => SBV c -> SBV b -> (SBV c -> SBV b) -> (SBV a -> SBV c -> SBV c) -> (SBV a -> SBV b -> SBV b) -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -736,12 +736,12 @@ -- -- >>> runTP $ foldrOverAppend @Integer (uninterpret "a") (uninterpret "f") -- Inductive lemma: foldrOverAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr -- [Proven] foldrOverAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool foldrOverAppend :: forall a. SymVal a => SBV a -> (SBV a -> SBV a -> SBV a) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) @@ -760,11 +760,11 @@ -- -- >>> runTP $ foldlOverAppend @Integer @Bool (uninterpret "f") -- Inductive lemma: foldlOverAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldl -- [Proven] foldlOverAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐe ∷ Bool → Bool foldlOverAppend :: forall a b. (SymVal a, SymVal b) => (SBV b -> SBV a -> SBV b) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "e" b -> SBool)) @@ -784,20 +784,20 @@ -- -- >>> runTP $ foldrFoldlDuality @Integer @String (uninterpret "f") -- Inductive lemma: foldlOverAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: foldrFoldlDuality --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldl, sbv.foldr, sbv.reverse -- [Proven] foldrFoldlDuality :: Ɐxs ∷ [Integer] → Ɐe ∷ String → Bool foldrFoldlDuality :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b -> SBV b) -> TP (Proof (Forall "xs" [a] -> Forall "e" b -> SBool)) @@ -835,21 +835,21 @@ -- -- >>> runTP $ foldrFoldlDualityGeneralized @Integer (uninterpret "e") (uninterpret "|@|") -- Inductive lemma: helper --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: foldrFoldlDuality --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldl, sbv.foldr -- [Proven] foldrFoldlDuality :: Ɐxs ∷ [Integer] → Bool foldrFoldlDualityGeneralized :: forall a. SymVal a => SBV a -> (SBV a -> SBV a -> SBV a) -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -905,20 +905,20 @@ -- -- >>> runTP $ foldrFoldl @Integer @String (uninterpret "<+>") (uninterpret "<*>") (uninterpret "e") -- Inductive lemma: foldl over <*>/<+> --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: foldrFoldl --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldl, sbv.foldr -- [Proven] foldrFoldl :: Ɐxs ∷ [Integer] → Bool foldrFoldl :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b -> SBV b) -> (SBV b -> SBV a -> SBV b) -> SBV b -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -965,28 +965,28 @@ -- -- >>> runTP $ bookKeeping @Integer (uninterpret "a") (uninterpret "f") -- Inductive lemma: foldBase --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: foldrOverAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: bookKeeping --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.map -- [Proven] bookKeeping :: Ɐxss ∷ [[Integer]] → Bool -- @@ -1047,13 +1047,13 @@ -- -- >>> runTP $ filterAppend @Integer (uninterpret "p") -- Inductive lemma: filterAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.filter -- [Proven] filterAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool filterAppend :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) @@ -1073,19 +1073,19 @@ -- -- >>> runTP $ filterConcat @Integer (uninterpret "f") -- Inductive lemma: filterAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: filterConcat --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.filter, sbv.foldr, sbv.map -- [Proven] filterConcat :: Ɐxss ∷ [[Integer]] → Bool filterConcat :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xss" [[a]] -> SBool)) @@ -1106,14 +1106,14 @@ -- -- >>> runTP $ takeDropWhile @Integer (uninterpret "f") -- Inductive lemma: takeDropWhile --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.dropWhile, sbv.takeWhile -- [Proven] takeDropWhile :: Ɐxs ∷ [Integer] → Bool takeDropWhile :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -1143,32 +1143,32 @@ -- -- >>> runTP $ destutterIdempotent @Integer -- Inductive lemma: helper1 --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: helper2 --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): helper3 --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3.1 Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3.1 Q.E.D. -- Step: 1.3.2 (2 way case split) --- Step: 1.3.2.1.1 Q.E.D. --- Step: 1.3.2.1.2 Q.E.D. --- Step: 1.3.2.2.1 Q.E.D. --- Step: 1.3.2.2.2 Q.E.D. --- Step: 1.3.2.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: destutterIdempotent Q.E.D. +-- Step: 1.3.2.1.1 Q.E.D. +-- Step: 1.3.2.1.2 Q.E.D. +-- Step: 1.3.2.2.1 Q.E.D. +-- Step: 1.3.2.2.2 Q.E.D. +-- Step: 1.3.2.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: destutterIdempotent Q.E.D. -- Functions proven terminating: destutter, noAdd -- [Proven] destutterIdempotent :: Ɐxs ∷ [Integer] → Bool destutterIdempotent :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool)) @@ -1236,11 +1236,11 @@ -- -- >>> runTP $ appendDiff @Integer -- Inductive lemma: appendDiff --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.diff -- [Proven] appendDiff :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Ɐcs ∷ [Integer] → Bool appendDiff :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> Forall "cs" [a] -> SBool)) @@ -1257,12 +1257,12 @@ -- -- >>> runTP $ diffAppend @Integer -- Inductive lemma: diffAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.diff -- [Proven] diffAppend :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Ɐcs ∷ [Integer] → Bool diffAppend :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> Forall "cs" [a] -> SBool)) @@ -1281,27 +1281,27 @@ -- -- >>> runTP $ diffDiff @Integer -- Inductive lemma: diffDiff --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. -- Step: 1.1.3 (2 way case split) --- Step: 1.1.3.1 Q.E.D. --- Step: 1.1.3.2.1 Q.E.D. --- Step: 1.1.3.2.2 (a ∉ cs) Q.E.D. --- Step: 1.1.3.Completeness Q.E.D. --- Step: 1.2.1 Q.E.D. +-- Step: 1.1.3.1 Q.E.D. +-- Step: 1.1.3.2.1 Q.E.D. +-- Step: 1.1.3.2.2 (a ∉ cs) Q.E.D. +-- Step: 1.1.3.Completeness Q.E.D. +-- Step: 1.2.1 Q.E.D. -- Step: 1.2.2 (2 way case split) --- Step: 1.2.2.1.1 Q.E.D. --- Step: 1.2.2.1.2 Q.E.D. --- Step: 1.2.2.1.3 (a ∈ cs) Q.E.D. --- Step: 1.2.2.2.1 Q.E.D. --- Step: 1.2.2.2.2 Q.E.D. --- Step: 1.2.2.2.3 (a ∉ bs) Q.E.D. --- Step: 1.2.2.2.4 (a ∉ cs) Q.E.D. --- Step: 1.2.2.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.2.2.1.1 Q.E.D. +-- Step: 1.2.2.1.2 Q.E.D. +-- Step: 1.2.2.1.3 (a ∈ cs) Q.E.D. +-- Step: 1.2.2.2.1 Q.E.D. +-- Step: 1.2.2.2.2 Q.E.D. +-- Step: 1.2.2.2.3 (a ∉ bs) Q.E.D. +-- Step: 1.2.2.2.4 (a ∉ cs) Q.E.D. +-- Step: 1.2.2.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.diff -- [Proven] diffDiff :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Ɐcs ∷ [Integer] → Bool diffDiff :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> Forall "cs" [a] -> SBool)) @@ -1349,10 +1349,10 @@ -- -- >>> runTP $ disjointDiff @Integer -- Inductive lemma: disjointDiff --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: disjoint, sbv.diff -- [Proven] disjointDiff :: Ɐas ∷ [Integer] → Ɐbs ∷ [Integer] → Bool disjointDiff :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "as" [a] -> Forall "bs" [a] -> SBool)) @@ -1369,12 +1369,12 @@ -- -- >>> runTP $ partition1 @Integer (uninterpret "f") -- Inductive lemma: partition1 --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.filter, sbv.partition -- [Proven] partition1 :: Ɐxs ∷ [Integer] → Bool partition1 :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -1396,12 +1396,12 @@ -- -- >>> runTP $ partition2 @Integer (uninterpret "f") -- Inductive lemma: partition2 --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.filter, sbv.partition -- [Proven] partition2 :: Ɐxs ∷ [Integer] → Bool partition2 :: forall a. SymVal a => (SBV a -> SBool) -> TP (Proof (Forall "xs" [a] -> SBool)) @@ -1422,7 +1422,7 @@ -- | @take n (take m xs) == take (n `smin` m) xs@ -- -- >>> runTP $ take_take @Integer --- Lemma: take_take Q.E.D. +-- Lemma: take_take Q.E.D. -- [Proven] take_take :: Ɐm ∷ Integer → Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool take_take :: forall a. SymVal a => TP (Proof (Forall "m" Integer -> Forall "n" Integer -> Forall "xs" [a] -> SBool)) take_take = lemma "take_take" @@ -1432,7 +1432,7 @@ -- | @n >= 0 && m >= 0 ==> drop n (drop m xs) == drop (n + m) xs@ -- -- >>> runTP $ drop_drop @Integer --- Lemma: drop_drop Q.E.D. +-- Lemma: drop_drop Q.E.D. -- [Proven] drop_drop :: Ɐm ∷ Integer → Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool drop_drop :: forall a. SymVal a => TP (Proof (Forall "m" Integer -> Forall "n" Integer -> Forall "xs" [a] -> SBool)) drop_drop = lemma "drop_drop" @@ -1442,7 +1442,7 @@ -- | @take n xs ++ drop n xs == xs@ -- -- >>> runTP $ take_drop @Integer --- Lemma: take_drop Q.E.D. +-- Lemma: take_drop Q.E.D. -- [Proven] take_drop :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool take_drop :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) take_drop = lemma "take_drop" @@ -1452,7 +1452,7 @@ -- | @n .> 0 ==> take n (x .: xs) == x .: take (n - 1) xs@ -- -- >>> runTP $ take_cons @Integer --- Lemma: take_cons Q.E.D. +-- Lemma: take_cons Q.E.D. -- [Proven] take_cons :: Ɐn ∷ Integer → Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool take_cons :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "x" a -> Forall "xs" [a] -> SBool)) take_cons = lemma "take_cons" @@ -1462,20 +1462,20 @@ -- | @take n (map f xs) == map f (take n xs)@ -- -- >>> runTP $ take_map @Integer @Integer (uninterpret "f") --- Lemma: take_cons Q.E.D. --- Lemma: map1 Q.E.D. --- Lemma: take_map.n <= 0 Q.E.D. +-- Lemma: take_cons Q.E.D. +-- Lemma: map1 Q.E.D. +-- Lemma: take_map.n <= 0 Q.E.D. -- Inductive lemma: take_map.n > 0 --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Lemma: take_map --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] take_map :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool take_map :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) @@ -1514,7 +1514,7 @@ -- | @n .> 0 ==> drop n (x .: xs) == drop (n - 1) xs@ -- -- >>> runTP $ drop_cons @Integer --- Lemma: drop_cons Q.E.D. +-- Lemma: drop_cons Q.E.D. -- [Proven] drop_cons :: Ɐn ∷ Integer → Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool drop_cons :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "x" a -> Forall "xs" [a] -> SBool)) drop_cons = lemma "drop_cons" @@ -1524,22 +1524,22 @@ -- | @drop n (map f xs) == map f (drop n xs)@ -- -- >>> runTP $ drop_map @Integer @String (uninterpret "f") --- Lemma: drop_cons Q.E.D. --- Lemma: drop_cons Q.E.D. --- Lemma: drop_map.n <= 0 Q.E.D. +-- Lemma: drop_cons Q.E.D. +-- Lemma: drop_cons Q.E.D. +-- Lemma: drop_map.n <= 0 Q.E.D. -- Inductive lemma: drop_map.n > 0 --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Lemma: drop_map --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map -- [Proven] drop_map :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool drop_map :: forall a b. (SymVal a, SymVal b) => (SBV a -> SBV b) -> TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) @@ -1580,7 +1580,7 @@ -- | @n >= 0 ==> length (take n xs) == length xs \`min\` n@ -- -- >>> runTP $ length_take @Integer --- Lemma: length_take Q.E.D. +-- Lemma: length_take Q.E.D. -- [Proven] length_take :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool length_take :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) length_take = lemma "length_take" @@ -1590,7 +1590,7 @@ -- | @n >= 0 ==> length (drop n xs) == (length xs - n) \`max\` 0@ -- -- >>> runTP $ length_drop @Integer --- Lemma: length_drop Q.E.D. +-- Lemma: length_drop Q.E.D. -- [Proven] length_drop :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool length_drop :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) length_drop = lemma "length_drop" @@ -1600,7 +1600,7 @@ -- | @length xs \<= n ==\> take n xs == xs@ -- -- >>> runTP $ take_all @Integer --- Lemma: take_all Q.E.D. +-- Lemma: take_all Q.E.D. -- [Proven] take_all :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool take_all :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) take_all = lemma "take_all" @@ -1610,7 +1610,7 @@ -- | @length xs \<= n ==\> drop n xs == []@ -- -- >>> runTP $ drop_all @Integer --- Lemma: drop_all Q.E.D. +-- Lemma: drop_all Q.E.D. -- [Proven] drop_all :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Bool drop_all :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> SBool)) drop_all = lemma "drop_all" @@ -1620,7 +1620,7 @@ -- | @take n (xs ++ ys) == (take n xs ++ take (n - length xs) ys)@ -- -- >>> runTP $ take_append @Integer --- Lemma: take_append Q.E.D. +-- Lemma: take_append Q.E.D. -- [Proven] take_append :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool take_append :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> Forall "ys" [a] -> SBool)) take_append = lemmaWith cvc5 "take_append" @@ -1632,7 +1632,7 @@ -- NB. As of Feb 2025, z3 struggles to prove this, but cvc5 gets it out-of-the-box. -- -- >>> runTP $ drop_append @Integer --- Lemma: drop_append Q.E.D. +-- Lemma: drop_append Q.E.D. -- [Proven] drop_append :: Ɐn ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool drop_append :: forall a. SymVal a => TP (Proof (Forall "n" Integer -> Forall "xs" [a] -> Forall "ys" [a] -> SBool)) drop_append = lemmaWith cvc5 "drop_append" @@ -1643,12 +1643,12 @@ -- -- >>> runTP $ map_fst_zip @Integer @Integer -- Inductive lemma: map_fst_zip --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.zip -- [Proven] map_fst_zip :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool map_fst_zip :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool)) @@ -1667,12 +1667,12 @@ -- -- >>> runTP $ map_snd_zip @Integer @Integer -- Inductive lemma: map_snd_zip --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.zip -- [Proven] map_snd_zip :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool map_snd_zip :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool)) @@ -1690,15 +1690,15 @@ -- | @map fst (zip xs ys) == take (min (length xs) (length ys)) xs@ -- -- >>> runTP $ map_fst_zip_take @Integer @Integer --- Lemma: take_cons Q.E.D. +-- Lemma: take_cons Q.E.D. -- Inductive lemma: map_fst_zip_take --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.zip -- [Proven] map_fst_zip_take :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool map_fst_zip_take :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool)) @@ -1720,15 +1720,15 @@ -- | @map snd (zip xs ys) == take (min (length xs) (length ys)) xs@ -- -- >>> runTP $ map_snd_zip_take @Integer @Integer --- Lemma: take_cons Q.E.D. +-- Lemma: take_cons Q.E.D. -- Inductive lemma: map_snd_zip_take --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.map, sbv.zip -- [Proven] map_snd_zip_take :: (Ɐxs ∷ [Integer], Ɐys ∷ [Integer]) → Bool map_snd_zip_take :: forall a b. (SymVal a, SymVal b) => TP (Proof ((Forall "xs" [a], Forall "ys" [b]) -> SBool)) @@ -1760,7 +1760,7 @@ -- @define-fun-rec@ but struggles to fold it back, so we provide this as a reusable hint. -- -- >>> runTP $ countOneStep @Integer --- Lemma: countOneStep Q.E.D. +-- Lemma: countOneStep Q.E.D. -- Functions proven terminating: count -- [Proven] countOneStep :: Ɐe ∷ Integer → Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool countOneStep :: forall a. SymVal a => TP (Proof (Forall "e" a -> Forall "x" a -> Forall "xs" [a] -> SBool)) @@ -1784,14 +1784,14 @@ -- -- >>> runTP $ interleaveLen @Integer -- Inductive lemma (strong): interleaveLen --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: interleave -- [Proven] interleaveLen :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool interleaveLen :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) @@ -1828,26 +1828,26 @@ -- We have: -- -- >>> runTP $ interleaveRoundTrip @Integer --- Lemma: revCons Q.E.D. +-- Lemma: revCons Q.E.D. -- Inductive lemma (strong): roundTripGen --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.3.4 Q.E.D. --- Step: 1.3.5 Q.E.D. --- Step: 1.3.6 Q.E.D. --- Step: 1.3.7 Q.E.D. --- Step: 1.3.8 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.3.4 Q.E.D. +-- Step: 1.3.5 Q.E.D. +-- Step: 1.3.6 Q.E.D. +-- Step: 1.3.7 Q.E.D. +-- Step: 1.3.8 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: interleaveRoundTrip --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: interleave, sbv.reverse, uninterleave -- [Proven] interleaveRoundTrip :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool interleaveRoundTrip :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) @@ -1897,12 +1897,12 @@ -- -- >>> runTP $ countAppend @Integer -- Inductive lemma: countAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 (unfold count) Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 (simplify) Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 (unfold count) Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 (simplify) Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] countAppend :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐe ∷ Integer → Bool countAppend :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "e" a -> SBool)) @@ -1923,17 +1923,17 @@ -- -- >>> runTP $ takeDropCount @Integer -- Inductive lemma: countAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 (unfold count) Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 (simplify) Q.E.D. --- Result: Q.E.D. --- Lemma: take_drop Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 (unfold count) Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 (simplify) Q.E.D. +-- Result: Q.E.D. +-- Lemma: take_drop Q.E.D. -- Lemma: takeDropCount --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] takeDropCount :: Ɐxs ∷ [Integer] → Ɐn ∷ Integer → Ɐe ∷ Integer → Bool takeDropCount :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "n" Integer -> Forall "e" a -> SBool)) @@ -1954,14 +1954,14 @@ -- -- >>> runTP $ countNonNeg @Integer -- Inductive lemma: countNonNeg --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] countNonNeg :: Ɐxs ∷ [Integer] → Ɐe ∷ Integer → Bool countNonNeg :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> Forall "e" a -> SBool)) @@ -1983,23 +1983,23 @@ -- -- >>> runTP $ countElem @Integer -- Inductive lemma: countNonNeg --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: countElem --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] countElem :: Ɐxs ∷ [Integer] → Ɐe ∷ Integer → Bool countElem :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "e" a -> SBool)) @@ -2025,13 +2025,13 @@ -- -- >>> runTP $ elemCount @Integer -- Inductive lemma: elemCount --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] elemCount :: Ɐxs ∷ [Integer] → Ɐe ∷ Integer → Bool elemCount :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "e" a -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Majority.hs b/Documentation/SBV/Examples/TP/Majority.hs --- a/Documentation/SBV/Examples/TP/Majority.hs +++ b/Documentation/SBV/Examples/TP/Majority.hs @@ -72,25 +72,25 @@ -- -- >>> correctness @Integer -- Inductive lemma: majorityGeneral --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. -- Step: 1.2.2 (2 way case split) --- Step: 1.2.2.1.1 Q.E.D. --- Step: 1.2.2.1.2 Q.E.D. --- Step: 1.2.2.2.1 Q.E.D. --- Step: 1.2.2.2.2 Q.E.D. --- Step: 1.2.2.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: majority Q.E.D. --- Lemma: ifExistsFound Q.E.D. --- Lemma: ifNoMajority Q.E.D. +-- Step: 1.2.2.1.1 Q.E.D. +-- Step: 1.2.2.1.2 Q.E.D. +-- Step: 1.2.2.2.1 Q.E.D. +-- Step: 1.2.2.2.2 Q.E.D. +-- Step: 1.2.2.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: majority Q.E.D. +-- Lemma: ifExistsFound Q.E.D. +-- Lemma: ifNoMajority Q.E.D. -- Lemma: uniqueness --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: count, majority -- ([Proven] majority :: Ɐc ∷ Integer → Ɐxs ∷ [Integer] → Bool,[Proven] ifExistsFound :: Ɐc ∷ Integer → Ɐxs ∷ [Integer] → Bool,[Proven] ifNoMajority :: Ɐc ∷ Integer → Ɐxs ∷ [Integer] → Bool,[Proven] uniqueness :: Ɐm1 ∷ Integer → Ɐm2 ∷ Integer → Ɐxs ∷ [Integer] → Bool) correctness :: forall a. SymVal a diff --git a/Documentation/SBV/Examples/TP/McCarthy91.hs b/Documentation/SBV/Examples/TP/McCarthy91.hs --- a/Documentation/SBV/Examples/TP/McCarthy91.hs +++ b/Documentation/SBV/Examples/TP/McCarthy91.hs @@ -49,20 +49,20 @@ -- and strong induction. We have: -- -- >>> correctness --- Lemma: case1 Q.E.D. --- Lemma: case2 Q.E.D. +-- Lemma: case1 Q.E.D. +-- Lemma: case2 Q.E.D. -- Inductive lemma (strong): case3 --- Step: Measure is non-negative Q.E.D. --- Step: 1 (unfold) Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Measure is non-negative Q.E.D. +-- Step: 1 (unfold) Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Lemma: mcCarthy91 -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: mcCarthy91 -- [Proven] mcCarthy91 :: Ɐn ∷ Integer → Bool correctness :: IO (Proof (Forall "n" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/MergeSort.hs b/Documentation/SBV/Examples/TP/MergeSort.hs --- a/Documentation/SBV/Examples/TP/MergeSort.hs +++ b/Documentation/SBV/Examples/TP/MergeSort.hs @@ -66,78 +66,78 @@ -- We have: -- -- >>> correctness @Integer --- Lemma: nonDecrInsert Q.E.D. +-- Lemma: nonDecrInsert Q.E.D. -- Inductive lemma: countAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 (unfold count) Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 (simplify) Q.E.D. --- Result: Q.E.D. --- Lemma: take_drop Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 (unfold count) Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 (simplify) Q.E.D. +-- Result: Q.E.D. +-- Lemma: take_drop Q.E.D. -- Lemma: takeDropCount --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. --- Lemma: countOneStep Q.E.D. --- Lemma: mergeHead Q.E.D. --- Lemma: mergeUnfold Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. +-- Lemma: countOneStep Q.E.D. +-- Lemma: mergeHead Q.E.D. +-- Lemma: mergeUnfold Q.E.D. -- Inductive lemma (strong): mergeKeepsSort --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. -- Step: 1.3 (2 way case split) --- Step: 1.3.1.1 (2 way case split) Q.E.D. --- Step: 1.3.1.2 Q.E.D. --- Step: 1.3.1.3 Q.E.D. --- Step: 1.3.2.1 (2 way case split) Q.E.D. --- Step: 1.3.2.2 Q.E.D. --- Step: 1.3.2.3 Q.E.D. --- Step: 1.3.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.3.1.1 (2 way case split) Q.E.D. +-- Step: 1.3.1.2 Q.E.D. +-- Step: 1.3.1.3 Q.E.D. +-- Step: 1.3.2.1 (2 way case split) Q.E.D. +-- Step: 1.3.2.2 Q.E.D. +-- Step: 1.3.2.3 Q.E.D. +-- Step: 1.3.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): sortNonDecreasing --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 (unfold) Q.E.D. --- Step: 1.2.2 (push nonDecreasing down) Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 (unfold) Q.E.D. +-- Step: 1.2.2 (push nonDecreasing down) Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): mergeCount --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3.1 (unfold merge) Q.E.D. --- Step: 1.3.2 (push count inside) Q.E.D. --- Step: 1.3.3 (unfold count, twice) Q.E.D. --- Step: 1.3.4 Q.E.D. --- Step: 1.3.5 Q.E.D. --- Step: 1.3.6 (unfold count in reverse, twice) Q.E.D. --- Step: 1.3.7 (simplify) Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3.1 (unfold merge) Q.E.D. +-- Step: 1.3.2 (push count inside) Q.E.D. +-- Step: 1.3.3 (unfold count, twice) Q.E.D. +-- Step: 1.3.4 Q.E.D. +-- Step: 1.3.5 Q.E.D. +-- Step: 1.3.6 (unfold count in reverse, twice) Q.E.D. +-- Step: 1.3.7 (simplify) Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): sortIsPermutation --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 (unfold mergeSort) Q.E.D. --- Step: 1.2.2 (push count down, simplify, rearrange) Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.2.5 Q.E.D. --- Step: 1.2.6 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: mergeSortIsCorrect Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 (unfold mergeSort) Q.E.D. +-- Step: 1.2.2 (push count down, simplify, rearrange) Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.2.5 Q.E.D. +-- Step: 1.2.6 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: mergeSortIsCorrect Q.E.D. -- Functions proven terminating: count, merge, mergeSort, nonDecreasing -- [Proven] mergeSortIsCorrect :: Ɐxs ∷ [Integer] → Bool correctness :: forall a. (OrdSymbolic (SBV a), SymVal a) => IO (Proof (Forall "xs" [a] -> SBool)) -correctness = runTPWith (tpRibbon 60 z3) $ do +correctness = runTP $ do -------------------------------------------------------------------------------------------- -- Part I. Import helper lemmas, definitions diff --git a/Documentation/SBV/Examples/TP/MutualCorecursion.hs b/Documentation/SBV/Examples/TP/MutualCorecursion.hs --- a/Documentation/SBV/Examples/TP/MutualCorecursion.hs +++ b/Documentation/SBV/Examples/TP/MutualCorecursion.hs @@ -61,10 +61,10 @@ -- -- >>> runTP pingLen -- Inductive lemma: pingLen --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven productive: ping, pong -- [Proven] pingLen :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool pingLen :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool)) @@ -81,10 +81,10 @@ -- -- >>> runTP pongLen -- Inductive lemma: pongLen --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven productive: ping, pong -- [Proven] pongLen :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool pongLen :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool)) @@ -100,7 +100,7 @@ -- | Indexing past a cons: @(x .: y) !! k == y !! (k - 1)@ when @k > 0@ and in bounds. -- -- >>> runTP consIndex --- Lemma: consIndex Q.E.D. +-- Lemma: consIndex Q.E.D. -- [Proven] consIndex :: Ɐx ∷ Integer → Ɐy ∷ [Integer] → Ɐk ∷ Integer → Bool consIndex :: TP (Proof (Forall "x" Integer -> Forall "y" [Integer] -> Forall "k" Integer -> SBool)) consIndex = lemma "consIndex" @@ -114,17 +114,17 @@ -- elements are the same, by induction on @k@. -- -- >>> runTP pingEqPong --- Lemma: pingLen Q.E.D. --- Lemma: pongLen Q.E.D. --- Lemma: consIndex Q.E.D. +-- Lemma: pingLen Q.E.D. +-- Lemma: pongLen Q.E.D. +-- Lemma: consIndex Q.E.D. -- Inductive lemma: pingEqPong --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven productive: ping, pong -- [Proven] pingEqPong :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool pingEqPong :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool)) @@ -152,17 +152,17 @@ -- | The @k@-th element of @ping n@ is @n + k@. -- -- >>> runTP pingElem --- Lemma: pingEqPong Q.E.D. --- Cached: consIndex Q.E.D. --- Cached: pongLen Q.E.D. +-- Lemma: pingEqPong Q.E.D. +-- Lemma: consIndex Q.E.D. [Cached] +-- Lemma: pongLen Q.E.D. [Cached] -- Inductive lemma: pingElem --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven productive: ping, pong -- [Proven] pingElem :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool pingElem :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/NatStream.hs b/Documentation/SBV/Examples/TP/NatStream.hs --- a/Documentation/SBV/Examples/TP/NatStream.hs +++ b/Documentation/SBV/Examples/TP/NatStream.hs @@ -50,7 +50,7 @@ -- NB. As of Mar 2026, z3 can't handle this but cvc5 can. -- -- >>> runTP natsHead --- Lemma: natsHead Q.E.D. +-- Lemma: natsHead Q.E.D. -- Functions proven productive: nats -- [Proven] natsHead :: Ɐn ∷ Integer → Bool natsHead :: TP (Proof (Forall "n" Integer -> SBool)) @@ -65,10 +65,10 @@ -- -- >>> runTP natsLen -- Inductive lemma: natsLen --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven productive: nats -- [Proven] natsLen :: Ɐm ∷ Integer → Ɐn ∷ Integer → Bool natsLen :: TP (Proof (Forall "m" Integer -> Forall "n" Integer -> SBool)) @@ -87,15 +87,15 @@ -- NB. As of Mar 2026, z3 can't handle this but cvc5 can. -- -- >>> runTP natsElem --- Lemma: natsLen Q.E.D. --- Lemma: elemOne Q.E.D. +-- Lemma: natsLen Q.E.D. +-- Lemma: elemOne Q.E.D. -- Inductive lemma: natsElem --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven productive: nats -- [Proven] natsElem :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool natsElem :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Numeric.hs b/Documentation/SBV/Examples/TP/Numeric.hs --- a/Documentation/SBV/Examples/TP/Numeric.hs +++ b/Documentation/SBV/Examples/TP/Numeric.hs @@ -40,12 +40,12 @@ -- -- >>> runTP $ sumConstProof (uninterpret "c") -- Inductive lemma: sumConst_correct --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.replicate -- [Proven] sumConst_correct :: Ɐn ∷ Integer → Bool sumConstProof :: SInteger -> TP (Proof (Forall "n" Integer -> SBool)) @@ -71,11 +71,11 @@ -- -- >>> runTP sumProof -- Inductive lemma: sum_correct --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, sbv.foldr -- [Proven] sum_correct :: Ɐn ∷ Integer → Bool @@ -95,14 +95,14 @@ -- -- >>> runTP sumSquareProof -- Inductive lemma: sumSquare_correct --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, -- sbv.foldr, sbv.map @@ -134,27 +134,27 @@ -- -- >>> runTP nicomachus -- Inductive lemma: sum_correct --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Lemma: evenHalfSquared Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: evenHalfSquared Q.E.D. -- Inductive lemma: nn1IsEven --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: sum_squared --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: nicomachus --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, -- sbv.foldr, sumCubed @@ -224,18 +224,18 @@ -- NB. As of Feb 2025, z3 struggles with the inductive step in this proof, but cvc5 performs just fine. -- -- >>> runTP elevenMinusFour --- Lemma: powN Q.E.D. +-- Lemma: powN Q.E.D. -- Inductive lemma: elevenMinusFour --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Step: 8 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Step: 8 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: pow -- [Proven] elevenMinusFour :: Ɐn ∷ Integer → Bool elevenMinusFour :: TP (Proof (Forall "n" Integer -> SBool)) @@ -276,21 +276,21 @@ -- -- >>> runTP sumMulFactorial -- Lemma: fact (n+1) --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: sumMulFactorial --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: -- EnumSymbolic.Integer.enumFromThenTo.down, EnumSymbolic.Integer.enumFromThenTo.up, -- sbv.foldr, sbv.map @@ -330,14 +330,14 @@ -- -- >>> runTP product0 -- Inductive lemma: product0 --- Step: Base Q.E.D. --- Step: 1 Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. -- Step: 2 (2 way case split) --- Step: 2.1 Q.E.D. --- Step: 2.2.1 Q.E.D. --- Step: 2.2.2 Q.E.D. --- Step: 2.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 2.1 Q.E.D. +-- Step: 2.2.1 Q.E.D. +-- Step: 2.2.2 Q.E.D. +-- Step: 2.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr -- [Proven] product0 :: Ɐxs ∷ [Integer] → Bool product0 :: TP (Proof (Forall "xs" [Integer] -> SBool)) @@ -361,7 +361,7 @@ -- -- >>> badNonNegative `catch` (\(_ :: SomeException) -> pure ()) -- Inductive lemma: badNonNegative --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 -- *** Failed to prove badNonNegative.1. -- Falsifiable. Counter-example: diff --git a/Documentation/SBV/Examples/TP/Peano.hs b/Documentation/SBV/Examples/TP/Peano.hs --- a/Documentation/SBV/Examples/TP/Peano.hs +++ b/Documentation/SBV/Examples/TP/Peano.hs @@ -115,7 +115,7 @@ -- | \(\overline{n} \geq 0\) -- -- >>> runTP n2iNonNeg --- Lemma: n2iNonNeg Q.E.D. +-- Lemma: n2iNonNeg Q.E.D. -- Functions proven terminating: n2i -- [Proven] n2iNonNeg :: Ɐn ∷ Nat → Bool n2iNonNeg :: TP (Proof (Forall "n" Nat -> SBool)) @@ -124,7 +124,7 @@ -- | \(\overline{\underline{i}} = \max(i, 0)\). -- -- >>> runTP i2n2i --- Lemma: i2n2i Q.E.D. +-- Lemma: i2n2i Q.E.D. -- Functions proven terminating: i2n, n2i -- [Proven] i2n2i :: Ɐi ∷ Integer → Bool i2n2i :: TP (Proof (Forall "i" Integer -> SBool)) @@ -133,7 +133,7 @@ -- | \(\underline{\overline{n}} = n\) -- -- >>> runTP n2i2n --- Lemma: n2i2n Q.E.D. +-- Lemma: n2i2n Q.E.D. -- Functions proven terminating: i2n, n2i -- [Proven] n2i2n :: Ɐn ∷ Nat → Bool n2i2n :: TP (Proof (Forall "n" Nat -> SBool)) @@ -142,7 +142,7 @@ -- | \(\overline{m + n} = \overline{m} + \overline{n}\) -- -- >>> runTP n2iAdd --- Lemma: n2iAdd Q.E.D. +-- Lemma: n2iAdd Q.E.D. -- Functions proven terminating: n2i, sNatPlus -- [Proven] n2iAdd :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool n2iAdd :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -155,7 +155,7 @@ -- | \(\overline{m + n} = \overline{m} + \overline{n}\) -- -- >>> runTP addCorrect --- Lemma: addCorrect Q.E.D. +-- Lemma: addCorrect Q.E.D. -- Functions proven terminating: n2i, sNatPlus -- [Proven] addCorrect :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool addCorrect :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -169,7 +169,7 @@ -- | \(0 + m = m\) -- -- >>> runTP addLeftUnit --- Lemma: addLeftUnit Q.E.D. +-- Lemma: addLeftUnit Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addLeftUnit :: Ɐm ∷ Nat → Bool addLeftUnit :: TP (Proof (Forall "m" Nat -> SBool)) @@ -178,7 +178,7 @@ -- | \(m + 0 = m\) -- -- >>> runTP addRightUnit --- Lemma: addRightUnit Q.E.D. +-- Lemma: addRightUnit Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addRightUnit :: Ɐm ∷ Nat → Bool addRightUnit :: TP (Proof (Forall "m" Nat -> SBool)) @@ -189,13 +189,13 @@ -- | \(m + \mathrm{Succ}\,n = \mathrm{Succ}\,(m + n)\) -- -- >>> runTP addSucc --- Lemma: caseZero Q.E.D. +-- Lemma: caseZero Q.E.D. -- Lemma: caseSucc --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Lemma: addSucc Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: addSucc Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addSucc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool addSucc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -225,7 +225,7 @@ -- | \(m + (n + o) = (m + n) + o\) -- -- >>> runTP addAssoc --- Lemma: addAssoc Q.E.D. +-- Lemma: addAssoc Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addAssoc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool addAssoc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool)) @@ -239,16 +239,16 @@ -- | \(m + n = n + m\) -- -- >>> runTP addComm --- Lemma: addLeftUnit Q.E.D. --- Lemma: addRightUnit Q.E.D. --- Lemma: caseZero Q.E.D. --- Lemma: addSucc Q.E.D. +-- Lemma: addLeftUnit Q.E.D. +-- Lemma: addRightUnit Q.E.D. +-- Lemma: caseZero Q.E.D. +-- Lemma: addSucc Q.E.D. -- Lemma: caseSucc --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Lemma: addComm Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: addComm Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addComm :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool addComm :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -284,16 +284,16 @@ -- | \(\overline{m * n} = \overline{m} * \overline{n}\) -- -- >>> runTP mulCorrect --- Lemma: caseZero Q.E.D. --- Lemma: addCorrect Q.E.D. +-- Lemma: caseZero Q.E.D. +-- Lemma: addCorrect Q.E.D. -- Lemma: caseSucc --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. --- Lemma: mullCorrect Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. +-- Lemma: mullCorrect Q.E.D. -- Functions proven terminating: n2i, sNatPlus, sNatTimes -- [Proven] mullCorrect :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool mulCorrect :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -328,7 +328,7 @@ -- | \(0 * m = 0\) -- -- >>> runTP mulLeftAbsorb --- Lemma: mulLeftAbsorb Q.E.D. +-- Lemma: mulLeftAbsorb Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulLeftAbsorb :: Ɐm ∷ Nat → Bool mulLeftAbsorb :: TP (Proof (Forall "m" Nat -> SBool)) @@ -337,7 +337,7 @@ -- | \(m * 0 = 0\) -- -- >>> runTP mulRightAbsorb --- Lemma: mulRightAbsorb Q.E.D. +-- Lemma: mulRightAbsorb Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulRightAbsorb :: Ɐm ∷ Nat → Bool mulRightAbsorb :: TP (Proof (Forall "m" Nat -> SBool)) @@ -348,7 +348,7 @@ -- | \(\mathrm{Succ\,0} * m = m\) -- -- >>> runTP mulLeftUnit --- Lemma: mulLeftUnit Q.E.D. +-- Lemma: mulLeftUnit Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulLeftUnit :: Ɐm ∷ Nat → Bool mulLeftUnit :: TP (Proof (Forall "m" Nat -> SBool)) @@ -357,7 +357,7 @@ -- | \(m * \mathrm{Succ\,0} = m\) -- -- >>> runTP mulRightUnit --- Lemma: mulRightUnit Q.E.D. +-- Lemma: mulRightUnit Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulRightUnit :: Ɐm ∷ Nat → Bool mulRightUnit :: TP (Proof (Forall "m" Nat -> SBool)) @@ -368,21 +368,21 @@ -- | \(m * (n + o) = m * n + m * o\) -- -- >>> runTP distribLeft --- Lemma: caseZero Q.E.D. --- Lemma: addAssoc Q.E.D. --- Lemma: addComm Q.E.D. +-- Lemma: caseZero Q.E.D. +-- Lemma: addAssoc Q.E.D. +-- Lemma: addComm Q.E.D. -- Lemma: caseSucc --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Step: 8 Q.E.D. --- Step: 9 Q.E.D. --- Result: Q.E.D. --- Lemma: distribLeft Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Step: 8 Q.E.D. +-- Step: 9 Q.E.D. +-- Result: Q.E.D. +-- Lemma: distribLeft Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] distribLeft :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool distribLeft :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool)) @@ -422,20 +422,20 @@ -- | \((m + n) * o = m * o + n * o\) -- -- >>> runTP distribRight --- Lemma: caseZero Q.E.D. --- Lemma: addAssoc Q.E.D. --- Lemma: addComm Q.E.D. --- Cached: addSucc Q.E.D. +-- Lemma: caseZero Q.E.D. +-- Lemma: addAssoc Q.E.D. +-- Lemma: addComm Q.E.D. +-- Lemma: addSucc Q.E.D. [Cached] -- Lemma: caseSucc --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Result: Q.E.D. --- Lemma: distribRight Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Result: Q.E.D. +-- Lemma: distribRight Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] distribRight :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool distribRight :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool)) @@ -475,17 +475,17 @@ -- | \(m * \mathrm{Succ}\,n = m * n + m\) -- -- >>> runTP mulSucc --- Lemma: addLeftUnit Q.E.D. --- Lemma: distribLeft Q.E.D. --- Lemma: mulRightUnit Q.E.D. --- Cached: addComm Q.E.D. +-- Lemma: addLeftUnit Q.E.D. +-- Lemma: distribLeft Q.E.D. +-- Lemma: mulRightUnit Q.E.D. +-- Lemma: addComm Q.E.D. [Cached] -- Lemma: mulSucc --- Step: 1 Q.E.D. --- Step: 2 (defn of +) Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 (defn of +) Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulSucc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool mulSucc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -515,15 +515,15 @@ -- | \(m * (n * o) = (m * n) * o\) -- -- >>> runTP mulAssoc --- Lemma: caseZero Q.E.D. --- Lemma: distribRight Q.E.D. +-- Lemma: caseZero Q.E.D. +-- Lemma: distribRight Q.E.D. -- Lemma: caseSucc --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. --- Lemma: mulAssoc Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. +-- Lemma: mulAssoc Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulAssoc :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool mulAssoc :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool)) @@ -557,19 +557,19 @@ -- | \(m * n = n * m\) -- -- >>> runTP mulComm --- Lemma: mulRightAbsorb Q.E.D. --- Lemma: caseZero Q.E.D. --- Lemma: mulRightUnit Q.E.D. --- Lemma: distribLeft Q.E.D. +-- Lemma: mulRightAbsorb Q.E.D. +-- Lemma: caseZero Q.E.D. +-- Lemma: mulRightUnit Q.E.D. +-- Lemma: distribLeft Q.E.D. -- Lemma: caseSucc --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. --- Lemma: mulComm Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. +-- Lemma: mulComm Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulComm :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool mulComm :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -610,15 +610,15 @@ -- | \(m < n \;\wedge\; n < o \;\rightarrow\; m < o\) -- -- >>> runTP ltTrans --- Lemma: addAssoc Q.E.D. +-- Lemma: addAssoc Q.E.D. -- Lemma: ltTrans --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] ltTrans :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool ltTrans :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool)) @@ -645,11 +645,11 @@ -- | \(\neg(m < m)\) -- -- >>> runTP ltIrreflexive --- Lemma: cancel Q.E.D. +-- Lemma: cancel Q.E.D. -- Lemma: ltIrreflexive --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] ltIrreflexive :: Ɐm ∷ Nat → Bool ltIrreflexive :: TP (Proof (Forall "m" Nat -> SBool)) @@ -672,37 +672,37 @@ -- | \(m \geq n = \overline{m} \geq \overline{n}\) -- -- >>> runTP lteEquiv --- Lemma: n2iAdd Q.E.D. --- Lemma: n2iNonNeg Q.E.D. --- Lemma: n2i2n Q.E.D. --- Lemma: i2n2i Q.E.D. --- Lemma: addRightUnit Q.E.D. +-- Lemma: n2iAdd Q.E.D. +-- Lemma: n2iNonNeg Q.E.D. +-- Lemma: n2i2n Q.E.D. +-- Lemma: i2n2i Q.E.D. +-- Lemma: addRightUnit Q.E.D. -- Lemma: lteEquiv_ltr -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: lteEquiv_rtl --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. -- Step: 7 (2 way case split) --- Step: 7.1 Q.E.D. --- Step: 7.2.1 Q.E.D. --- Step: 7.2.2 Q.E.D. --- Step: 7.2.3 Q.E.D. --- Step: 7.2.4 Q.E.D. --- Step: 7.2.5 Q.E.D. --- Step: 7.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: lteEquiv Q.E.D. +-- Step: 7.1 Q.E.D. +-- Step: 7.2.1 Q.E.D. +-- Step: 7.2.2 Q.E.D. +-- Step: 7.2.3 Q.E.D. +-- Step: 7.2.4 Q.E.D. +-- Step: 7.2.5 Q.E.D. +-- Step: 7.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: lteEquiv Q.E.D. -- Functions proven terminating: i2n, n2i, sNatPlus -- [Proven] lteEquiv :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool lteEquiv :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -762,11 +762,11 @@ -- | \(m \geq n \;\lor\; n \geq m\) -- -- >>> runTP ordered --- Lemma: lteEquiv Q.E.D. +-- Lemma: lteEquiv Q.E.D. -- Lemma: ordered --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: i2n, n2i, sNatPlus -- [Proven] ordered :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool ordered :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -785,8 +785,8 @@ -- | \(m < n \;\lor\; m = n \;\lor\; n < m\) -- -- >>> runTP trichotomy --- Lemma: ordered Q.E.D. --- Lemma: trichotomy Q.E.D. +-- Lemma: ordered Q.E.D. +-- Lemma: trichotomy Q.E.D. -- Functions proven terminating: i2n, n2i, sNatPlus -- [Proven] trichotomy :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool trichotomy :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -802,15 +802,15 @@ -- | \(m < n \;\rightarrow\; m + o < n + o\) -- -- >>> runTP addOrder --- Lemma: addAssoc Q.E.D. --- Lemma: addComm Q.E.D. +-- Lemma: addAssoc Q.E.D. +-- Lemma: addComm Q.E.D. -- Lemma: addOrder --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] addOrder :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool addOrder :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool)) @@ -838,15 +838,15 @@ -- | \(o > 0 \;\wedge\; m < n \;\rightarrow\; m * o < n * o\) -- -- >>> runTP mulOrder --- Lemma: distribRight Q.E.D. +-- Lemma: distribRight Q.E.D. -- Lemma: mulOrder --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sNatPlus, sNatTimes -- [Proven] mulOrder :: Ɐm ∷ Nat → Ɐn ∷ Nat → Ɐo ∷ Nat → Bool mulOrder :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> Forall "o" Nat -> SBool)) @@ -873,7 +873,7 @@ -- | \(m < n \;\rightarrow\; \exists o.\; m + o = n\) -- -- >>> runTP orderSum --- Lemma: orderSum Q.E.D. +-- Lemma: orderSum Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] orderSum :: Ɐm ∷ Nat → Ɐn ∷ Nat → Bool orderSum :: TP (Proof (Forall "m" Nat -> Forall "n" Nat -> SBool)) @@ -886,7 +886,7 @@ -- | \(0 < 1\) -- -- >>> runTP zeroLtOne --- Lemma: zeroLtOne Q.E.D. +-- Lemma: zeroLtOne Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] zeroLtOne :: Bool zeroLtOne :: TP (Proof SBool) @@ -895,7 +895,7 @@ -- | \(m > 0 \;\rightarrow\; m \geq 1\) -- -- >>> runTP nothingBetweenZeroAndOne --- Lemma: nothingBetweenZeroAndOne Q.E.D. +-- Lemma: nothingBetweenZeroAndOne Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] nothingBetweenZeroAndOne :: Ɐm ∷ Nat → Bool nothingBetweenZeroAndOne :: TP (Proof (Forall "m" Nat -> SBool)) @@ -908,7 +908,7 @@ -- | \(m \geq 0\) -- -- >>> runTP minimumElt --- Lemma: minimumElt Q.E.D. +-- Lemma: minimumElt Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] minimumElt :: Ɐm ∷ Nat → Bool minimumElt :: TP (Proof (Forall "m" Nat -> SBool)) @@ -919,7 +919,7 @@ -- | \(\forall m \;\exists n \;.\; m < n\) -- -- >>> runTP noMaximumElt --- Lemma: noMaximumElt Q.E.D. +-- Lemma: noMaximumElt Q.E.D. -- Functions proven terminating: sNatPlus -- [Proven] noMaximumElt :: Ɐm ∷ Nat → ∃n ∷ Nat → Bool noMaximumElt :: TP (Proof (Forall "m" Nat -> Exists "n" Nat -> SBool)) diff --git a/Documentation/SBV/Examples/TP/PigeonHole.hs b/Documentation/SBV/Examples/TP/PigeonHole.hs --- a/Documentation/SBV/Examples/TP/PigeonHole.hs +++ b/Documentation/SBV/Examples/TP/PigeonHole.hs @@ -36,10 +36,10 @@ -- -- >>> runTP pigeonHole -- Inductive lemma: pigeonHole --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr --[Proven] pigeonHole :: Ɐxs ∷ [Integer] → Bool pigeonHole :: TP (Proof (Forall "xs" [Integer] -> SBool)) diff --git a/Documentation/SBV/Examples/TP/PowerMod.hs b/Documentation/SBV/Examples/TP/PowerMod.hs --- a/Documentation/SBV/Examples/TP/PowerMod.hs +++ b/Documentation/SBV/Examples/TP/PowerMod.hs @@ -42,17 +42,17 @@ -- ==== __Proof__ -- >>> runTP modAddMultiple -- Inductive lemma: modAddMultiplePos --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- [Proven] modAddMultiple :: Ɐk ∷ Integer → Ɐn ∷ Integer → Ɐm ∷ Integer → Bool modAddMultiple :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> Forall "m" Integer -> SBool)) modAddMultiple = do @@ -89,21 +89,21 @@ -- ==== __Proof__ -- >>> runTP modAddRight -- Inductive lemma: modAddMultiplePos --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddRight --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- [Proven] modAddRight :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modAddRight :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modAddRight = do @@ -121,26 +121,26 @@ -- ==== __Proof__ -- >>> runTP modAddLeft -- Inductive lemma: modAddMultiplePos --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddRight --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddLeft --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- [Proven] modAddLeft :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modAddLeft :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modAddLeft = do @@ -159,22 +159,22 @@ -- ==== __Proof__ -- >>> runTP modSubRight -- Inductive lemma: modAddMultiplePos --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: modSubRight --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- [Proven] modSubRight :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modSubRight :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modSubRight = do @@ -194,36 +194,36 @@ -- ==== __Proof__ -- >>> runTP modMulRightNonneg -- Inductive lemma: modAddMultiplePos --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddRight --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddLeft --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Cached: modAddRight Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: modAddRight Q.E.D. [Cached] -- Inductive lemma: modMulRightNonneg --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- [Proven] modMulRightNonneg :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modMulRightNonneg :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modMulRightNonneg = do @@ -250,36 +250,36 @@ -- ==== __Proof__ -- >>> runTP modMulRightNeg -- Inductive lemma: modAddMultiplePos --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddRight --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddLeft --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Lemma: modSubRight Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: modSubRight Q.E.D. -- Inductive lemma: modMulRightNeg --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- [Proven] modMulRightNeg :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modMulRightNeg :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modMulRightNeg = do @@ -306,45 +306,45 @@ -- ==== __Proof__ -- >>> runTP modMulRight -- Inductive lemma: modAddMultiplePos --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddMultiple -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddRight --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Lemma: modAddLeft --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Cached: modAddRight Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: modAddRight Q.E.D. [Cached] -- Inductive lemma: modMulRightNonneg --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. --- Lemma: modMulRightNeg Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. +-- Lemma: modMulRightNeg Q.E.D. -- Lemma: modMulRight -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- [Proven] modMulRight :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modMulRight :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modMulRight = do @@ -369,12 +369,12 @@ -- -- ==== __Proof__ -- >>> runTP modMulLeft --- Lemma: modMulRight Q.E.D. +-- Lemma: modMulRight Q.E.D. -- Lemma: modMulLeft --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- [Proven] modMulLeft :: Ɐa ∷ Integer → Ɐb ∷ Integer → Ɐm ∷ Integer → Bool modMulLeft :: TP (Proof (Forall "a" Integer -> Forall "b" Integer -> Forall "m" Integer -> SBool)) modMulLeft = do @@ -393,18 +393,18 @@ -- -- ==== __Proof__ -- >>> runTP powerMod --- Lemma: modMulLeft Q.E.D. --- Cached: modMulRight Q.E.D. +-- Lemma: modMulLeft Q.E.D. +-- Lemma: modMulRight Q.E.D. [Cached] -- Inductive lemma: powerModInduct --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. --- Lemma: powerMod Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. +-- Lemma: powerMod Q.E.D. -- Functions proven terminating: power -- [Proven] powerMod :: Ɐb ∷ Integer → Ɐn ∷ Integer → Ɐm ∷ Integer → Bool powerMod :: TP (Proof (Forall "b" Integer -> Forall "n" Integer -> Forall "m" Integer -> SBool)) @@ -438,10 +438,10 @@ -- ==== __Proof__ -- >>> runTP onePower -- Inductive lemma: onePower --- Step: Base Q.E.D. --- Step: 1 (unfold power) Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 (unfold power) Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: power -- [Proven] onePower :: Ɐn ∷ Integer → Bool onePower :: TP (Proof (Forall "n" Integer -> SBool)) @@ -458,14 +458,14 @@ -- -- ==== __Proof__ -- >>> runTP powerOf27 --- Lemma: onePower Q.E.D. --- Lemma: powerMod Q.E.D. +-- Lemma: onePower Q.E.D. +-- Lemma: powerMod Q.E.D. -- Lemma: powerOf27 --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: power -- [Proven] powerOf27 :: Ɐn ∷ Integer → Bool powerOf27 :: TP (Proof (Forall "n" Integer -> SBool)) @@ -487,10 +487,10 @@ -- -- ==== __Proof__ -- >>> runTP powerOfThreeMod13VarDivisor --- Lemma: powerOf27 Q.E.D. +-- Lemma: powerOf27 Q.E.D. -- Lemma: powerOfThreeMod13VarDivisor --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: power -- [Proven] powerOfThreeMod13VarDivisor :: Ɐn ∷ Integer → Ɐm ∷ Integer → Bool powerOfThreeMod13VarDivisor :: TP (Proof (Forall "n" Integer -> Forall "m" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Primes.hs b/Documentation/SBV/Examples/TP/Primes.hs --- a/Documentation/SBV/Examples/TP/Primes.hs +++ b/Documentation/SBV/Examples/TP/Primes.hs @@ -41,12 +41,12 @@ -- >>> runTP dividesProduct -- Lemma: dividesProduct -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- [Proven] dividesProduct :: Ɐx ∷ Integer → Ɐy ∷ Integer → Ɐz ∷ Integer → Bool dividesProduct :: TP (Proof (Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> SBool)) dividesProduct = calc "dividesProduct" @@ -67,16 +67,16 @@ -- -- === __Proof__ -- >>> runTP dividesTransitive --- Lemma: dividesProduct Q.E.D. +-- Lemma: dividesProduct Q.E.D. -- Lemma: dividesTransitive -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- [Proven] dividesTransitive :: Ɐx ∷ Integer → Ɐy ∷ Integer → Ɐz ∷ Integer → Bool dividesTransitive :: TP (Proof (Forall "x" Integer -> Forall "y" Integer -> Forall "z" Integer -> SBool)) dividesTransitive = do @@ -117,12 +117,12 @@ -- === __Proof__ -- >>> runTP leastDivisorDivides -- Inductive lemma (strong): leastDivisorDivides --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ld -- [Proven] leastDivisorDivides :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool leastDivisorDivides :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool)) @@ -148,12 +148,12 @@ -- === __Proof__ -- >>> runTP leastDivisorIsLeast -- Inductive lemma (strong): leastDivisorisLeast --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ld -- [Proven] leastDivisorisLeast :: Ɐk ∷ Integer → Ɐn ∷ Integer → Ɐd ∷ Integer → Bool leastDivisorIsLeast :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> Forall "d" Integer -> SBool)) @@ -175,19 +175,19 @@ -- -- === __Proof__ -- >>> runTP leastDivisorTwice --- Lemma: dividesTransitive Q.E.D. --- Lemma: leastDivisorDivides Q.E.D. --- Lemma: leastDivisorisLeast Q.E.D. --- Lemma: helper1 Q.E.D. --- Lemma: helper2 Q.E.D. +-- Lemma: dividesTransitive Q.E.D. +-- Lemma: leastDivisorDivides Q.E.D. +-- Lemma: leastDivisorisLeast Q.E.D. +-- Lemma: helper1 Q.E.D. +-- Lemma: helper2 Q.E.D. -- Lemma: helper3 --- Step: 1 Q.E.D. --- Result: Q.E.D. --- Lemma: helper4 Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. +-- Lemma: helper4 Q.E.D. -- Lemma: helper5 --- Step: 1 Q.E.D. --- Result: Q.E.D. --- Lemma: leastDivisorTwice Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. +-- Lemma: leastDivisorTwice Q.E.D. -- Functions proven terminating: ld -- [Proven] leastDivisorTwice :: Ɐk ∷ Integer → Ɐn ∷ Integer → Bool leastDivisorTwice :: TP (Proof (Forall "k" Integer -> Forall "n" Integer -> SBool)) @@ -243,7 +243,7 @@ -- -- === __Proof__ -- >>> runTP primeAtLeast2 --- Lemma: primeAtLeast2 Q.E.D. +-- Lemma: primeAtLeast2 Q.E.D. -- Functions proven terminating: ld -- [Proven] primeAtLeast2 :: Ɐp ∷ Integer → Bool primeAtLeast2 :: TP (Proof (Forall "p" Integer -> SBool)) @@ -253,11 +253,11 @@ -- -- === __Proof__ -- >>> runTP leastDivisorIsPrime --- Lemma: leastDivisorTwice Q.E.D. --- Cached: leastDivisorDivides Q.E.D. +-- Lemma: leastDivisorTwice Q.E.D. +-- Lemma: leastDivisorDivides Q.E.D. [Cached] -- Lemma: leastDivisorIsPrime --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ld -- [Proven] leastDivisorIsPrime :: Ɐn ∷ Integer → Bool leastDivisorIsPrime :: TP (Proof (Forall "n" Integer -> SBool)) @@ -292,13 +292,13 @@ -- === __Proof__ -- >>> runTP factAtLeast1 -- Inductive lemma: factAtLeast1 --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: fact -- [Proven] factAtLeast1 :: Ɐn ∷ Integer → Bool factAtLeast1 :: TP (Proof (Forall "n" Integer -> SBool)) @@ -316,17 +316,17 @@ -- -- === __Proof__ -- >>> runTP dividesFact --- Lemma: dividesProduct Q.E.D. +-- Lemma: dividesProduct Q.E.D. -- Inductive lemma: dividesFact --- Step: Base Q.E.D. --- Step: 1 Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. -- Step: 2 (2 way case split) --- Step: 2.1.1 Q.E.D. --- Step: 2.1.2 Q.E.D. --- Step: 2.2.1 Q.E.D. --- Step: 2.2.2 Q.E.D. --- Step: 2.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 2.1.1 Q.E.D. +-- Step: 2.1.2 Q.E.D. +-- Step: 2.2.1 Q.E.D. +-- Step: 2.2.2 Q.E.D. +-- Step: 2.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: fact -- [Proven] dividesFact :: Ɐn ∷ Integer → Ɐk ∷ Integer → Bool dividesFact :: TP (Proof (Forall "n" Integer -> Forall "k" Integer -> SBool)) @@ -353,12 +353,12 @@ -- -- === __Proof__ -- >>> runTP notDividesFactP1 --- Lemma: dividesFact Q.E.D. +-- Lemma: dividesFact Q.E.D. -- Lemma: notDividesFactP1 --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: fact -- [Proven] notDividesFactP1 :: Ɐn ∷ Integer → Ɐk ∷ Integer → Bool notDividesFactP1 :: TP (Proof (Forall "n" Integer -> Forall "k" Integer -> SBool)) @@ -385,13 +385,13 @@ -- -- === __Proof__ -- >>> runTP greaterPrimeDivides --- Lemma: leastDivisorDivides Q.E.D. --- Lemma: factAtLeast1 Q.E.D. +-- Lemma: leastDivisorDivides Q.E.D. +-- Lemma: factAtLeast1 Q.E.D. -- Lemma: greaterPrimeDivides --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: fact, ld -- [Proven] greaterPrimeDivides :: Ɐn ∷ Integer → Bool greaterPrimeDivides :: TP (Proof (Forall "n" Integer -> SBool)) @@ -413,19 +413,19 @@ -- -- === __Proof__ -- >>> runTP greaterPrimeGreater --- Lemma: notDividesFactP1 Q.E.D. --- Lemma: greaterPrimeDivides Q.E.D. --- Lemma: leastDivisorIsPrime Q.E.D. --- Cached: factAtLeast1 Q.E.D. --- Lemma: primeAtLeast2 Q.E.D. +-- Lemma: notDividesFactP1 Q.E.D. +-- Lemma: greaterPrimeDivides Q.E.D. +-- Lemma: leastDivisorIsPrime Q.E.D. +-- Lemma: factAtLeast1 Q.E.D. [Cached] +-- Lemma: primeAtLeast2 Q.E.D. -- Lemma: greaterPrimeGreater --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: fact, ld -- [Proven] greaterPrimeGreater :: Ɐn ∷ Integer → Bool greaterPrimeGreater :: TP (Proof (Forall "n" Integer -> SBool)) @@ -461,14 +461,14 @@ -- -- === __Proof__ -- >>> runTP infinitudeOfPrimes --- Lemma: leastDivisorIsPrime Q.E.D. --- Lemma: factAtLeast1 Q.E.D. --- Lemma: greaterPrimeGreater Q.E.D. +-- Lemma: leastDivisorIsPrime Q.E.D. +-- Lemma: factAtLeast1 Q.E.D. +-- Lemma: greaterPrimeGreater Q.E.D. -- Lemma: infinitudeOfPrimes --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: fact, ld -- [Proven] infinitudeOfPrimes :: Ɐn ∷ Integer → Bool infinitudeOfPrimes :: TP (Proof (Forall "n" Integer -> SBool)) @@ -496,11 +496,11 @@ -- -- === __Proof__ -- >>> runTP noLargestPrime --- Lemma: infinitudeOfPrimes Q.E.D. +-- Lemma: infinitudeOfPrimes Q.E.D. -- Lemma: helper --- Step: 1 Q.E.D. --- Result: Q.E.D. --- Lemma: noLargestPrime Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. +-- Lemma: noLargestPrime Q.E.D. -- Functions proven terminating: fact, ld -- [Proven] noLargestPrime :: Ɐn ∷ Integer → ∃p ∷ Integer → Bool noLargestPrime :: TP (Proof (Forall "n" Integer -> Exists "p" Integer -> SBool)) diff --git a/Documentation/SBV/Examples/TP/QuickSort.hs b/Documentation/SBV/Examples/TP/QuickSort.hs --- a/Documentation/SBV/Examples/TP/QuickSort.hs +++ b/Documentation/SBV/Examples/TP/QuickSort.hs @@ -74,14 +74,14 @@ -- -- >>> runTP $ partitionFstBound @Integer -- Inductive lemma (strong): partitionNotLongerFst --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 (simplify) Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 (simplify) Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: partition -- [Proven] partitionNotLongerFst :: Ɐl ∷ [Integer] → Ɐpivot ∷ Integer → Bool partitionFstBound :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "l" [a] -> Forall "pivot" a -> SBool)) @@ -109,14 +109,14 @@ -- -- >>> runTP $ partitionSndBound @Integer -- Inductive lemma (strong): partitionNotLongerSnd --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 (simplify) Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 (simplify) Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: partition -- [Proven] partitionNotLongerSnd :: Ɐl ∷ [Integer] → Ɐpivot ∷ Integer → Bool partitionSndBound :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "l" [a] -> Forall "pivot" a -> SBool)) @@ -147,155 +147,154 @@ -- -- >>> correctness @Integer -- Inductive lemma: countAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 (unfold count) Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 (simplify) Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 (unfold count) Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 (simplify) Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: countNonNeg --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: countElem --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: elemCount --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: sublistCorrect --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Lemma: sublistElem --- Step: 1 Q.E.D. --- Result: Q.E.D. --- Lemma: sublistTail Q.E.D. --- Lemma: sublistIfPerm Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. +-- Lemma: sublistTail Q.E.D. +-- Lemma: sublistIfPerm Q.E.D. -- Inductive lemma: lltCorrect --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: lgeCorrect --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: lltSublist --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Lemma: lltPermutation --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: lgeSublist --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Lemma: lgePermutation --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: partitionFstLT --- Step: Base Q.E.D. --- Step: 1 (unroll partition) Q.E.D. --- Step: 2 (push fst down, simplify) Q.E.D. --- Step: 3 (push llt down) Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 (unroll partition) Q.E.D. +-- Step: 2 (push fst down, simplify) Q.E.D. +-- Step: 3 (push llt down) Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: partitionSndGE --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 (push lge down) Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Lemma: partitionNotLongerFst Q.E.D. --- Lemma: partitionNotLongerSnd Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 (push lge down) Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: partitionNotLongerFst Q.E.D. +-- Lemma: partitionNotLongerSnd Q.E.D. -- Inductive lemma: countPartition --- Step: Base Q.E.D. --- Step: 1 (expand partition) Q.E.D. --- Step: 2 (push countTuple down) Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 (expand partition) Q.E.D. +-- Step: 2 (push countTuple down) Q.E.D. -- Step: 3 (2 way case split) --- Step: 3.1.1 Q.E.D. --- Step: 3.1.2 (simplify) Q.E.D. --- Step: 3.1.3 Q.E.D. --- Step: 3.2.1 Q.E.D. --- Step: 3.2.2 (simplify) Q.E.D. --- Step: 3.2.3 Q.E.D. --- Step: 3.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 3.1.1 Q.E.D. +-- Step: 3.1.2 (simplify) Q.E.D. +-- Step: 3.1.3 Q.E.D. +-- Step: 3.2.1 Q.E.D. +-- Step: 3.2.2 (simplify) Q.E.D. +-- Step: 3.2.3 Q.E.D. +-- Step: 3.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): sortCountsMatch --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 (expand quickSort) Q.E.D. --- Step: 1.2.3 (push count down) Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.2.5 Q.E.D. --- Step: 1.2.6 (IH on lo) Q.E.D. --- Step: 1.2.7 (IH on hi) Q.E.D. --- Step: 1.2.8 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: sortIsPermutation Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 (expand quickSort) Q.E.D. +-- Step: 1.2.3 (push count down) Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.2.5 Q.E.D. +-- Step: 1.2.6 (IH on lo) Q.E.D. +-- Step: 1.2.7 (IH on hi) Q.E.D. +-- Step: 1.2.8 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: sortIsPermutation Q.E.D. -- Inductive lemma: nonDecreasingMerge --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.2.5 Q.E.D. --- Step: 1.2.6 Q.E.D. --- Step: 1.2.7 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.2.5 Q.E.D. +-- Step: 1.2.6 Q.E.D. +-- Step: 1.2.7 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): sortIsNonDecreasing --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 (expand quickSort) Q.E.D. --- Step: 1.2.3 (push nonDecreasing down) Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: quickSortIsCorrect Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 (expand quickSort) Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: quickSortIsCorrect Q.E.D. -- Inductive lemma: partitionSortedLeft --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: partitionSortedRight --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: unchangedIfNondecreasing --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. --- Lemma: ifChangedThenUnsorted Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. +-- Lemma: ifChangedThenUnsorted Q.E.D. -- == Proof tree: -- quickSortIsCorrect -- ├╴sortIsPermutation @@ -330,7 +329,7 @@ -- Functions proven terminating: count, lge, llt, nonDecreasing, partition, quickSort -- [Proven] quickSortIsCorrect :: Ɐxs ∷ [Integer] → Bool correctness :: forall a. (Eq a, OrdSymbolic (SBV a), SymVal a) => IO (Proof (Forall "xs" [a] -> SBool)) -correctness = runTPWith (tpRibbon 60 z3) $ do +correctness = runTP $ do -------------------------------------------------------------------------------------------- -- Part I. Import helper lemmas, definitions @@ -538,28 +537,27 @@ =: [pCase| xs of [] -> trivial whole@(a : as) -> - count e (quickSort whole) - ?? "expand quickSort" - =: count e (case partition a as of - (lo, hi) -> quickSort lo ++ [a] ++ quickSort hi) - ?? "push count down" - =: case partition a as of - (lo, hi) -> count e (quickSort lo ++ [a] ++ quickSort hi) - ?? countAppend `at` (Inst @"xs" (quickSort lo), Inst @"ys" ([a] ++ quickSort hi), Inst @"e" e) - =: count e (quickSort lo) + count e ([a] ++ quickSort hi) - ?? countAppend `at` (Inst @"xs" [a], Inst @"ys" (quickSort hi), Inst @"e" e) - =: count e (quickSort lo) + count e [a] + count e (quickSort hi) - ?? ih `at` (Inst @"xs" lo, Inst @"e" e) - ?? partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a) - ?? "IH on lo" - =: count e lo + count e [a] + count e (quickSort hi) - ?? ih `at` (Inst @"xs" hi, Inst @"e" e) - ?? partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a) - ?? "IH on hi" - =: count e lo + count e [a] + count e hi - ?? countPartition `at` (Inst @"xs" as, Inst @"pivot" a, Inst @"e" e) - =: count e xs - =: qed + let (lo, hi) = untuple (partition a as) + in count e (quickSort whole) + ?? "expand quickSort" + =: count e (quickSort lo ++ [a] ++ quickSort hi) + ?? "push count down" + =: count e (quickSort lo ++ [a] ++ quickSort hi) + ?? countAppend `at` (Inst @"xs" (quickSort lo), Inst @"ys" ([a] ++ quickSort hi), Inst @"e" e) + =: count e (quickSort lo) + count e ([a] ++ quickSort hi) + ?? countAppend `at` (Inst @"xs" [a], Inst @"ys" (quickSort hi), Inst @"e" e) + =: count e (quickSort lo) + count e [a] + count e (quickSort hi) + ?? ih `at` (Inst @"xs" lo, Inst @"e" e) + ?? partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a) + ?? "IH on lo" + =: count e lo + count e [a] + count e (quickSort hi) + ?? ih `at` (Inst @"xs" hi, Inst @"e" e) + ?? partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a) + ?? "IH on hi" + =: count e lo + count e [a] + count e hi + ?? countPartition `at` (Inst @"xs" as, Inst @"pivot" a, Inst @"e" e) + =: count e xs + =: qed |] sortIsPermutation <- lemma "sortIsPermutation" (\(Forall xs) -> isPermutation xs (quickSort xs)) [proofOf sortCountsMatch] @@ -603,37 +601,34 @@ =: [pCase| xs of [] -> trivial whole@(a : as) -> - nonDecreasing (quickSort whole) + let (lo, hi) = untuple (partition a as) + in nonDecreasing (quickSort whole) ?? "expand quickSort" - =: nonDecreasing (case partition a as of - (lo, hi) -> quickSort lo ++ [a] ++ quickSort hi) - ?? "push nonDecreasing down" - =: case partition a as of - (lo, hi) -> nonDecreasing (quickSort lo ++ [a] ++ quickSort hi) - -- Deduce that lo/hi is not longer than as, and hence, shorter than xs - ?? partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a) - ?? partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a) + =: nonDecreasing (quickSort lo ++ [a] ++ quickSort hi) + -- Deduce that lo/hi is not longer than as, and hence, shorter than xs + ?? partitionNotLongerFst `at` (Inst @"l" as, Inst @"pivot" a) + ?? partitionNotLongerSnd `at` (Inst @"l" as, Inst @"pivot" a) - -- Use the inductive hypothesis twice to deduce quickSort of lo and hi are nonDecreasing - ?? ih `at` Inst @"xs" lo -- nonDecreasing (quickSort lo) - ?? ih `at` Inst @"xs" hi -- nonDecreasing (quickSort hi) + -- Use the inductive hypothesis twice to deduce quickSort of lo and hi are nonDecreasing + ?? ih `at` Inst @"xs" lo -- nonDecreasing (quickSort lo) + ?? ih `at` Inst @"xs" hi -- nonDecreasing (quickSort hi) - -- Deduce that lo is all less than a, and hi is all greater than or equal to a - ?? partitionFstLT `at` (Inst @"l" as, Inst @"pivot" a) - ?? partitionSndGE `at` (Inst @"l" as, Inst @"pivot" a) + -- Deduce that lo is all less than a, and hi is all greater than or equal to a + ?? partitionFstLT `at` (Inst @"l" as, Inst @"pivot" a) + ?? partitionSndGE `at` (Inst @"l" as, Inst @"pivot" a) - -- Deduce that quickSort lo is all less than a - ?? sortIsPermutation `at` Inst @"xs" lo - ?? lltPermutation `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" lo) + -- Deduce that quickSort lo is all less than a + ?? sortIsPermutation `at` Inst @"xs" lo + ?? lltPermutation `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" lo) - -- Deduce that quickSort hi is all greater than or equal to a - ?? sortIsPermutation `at` Inst @"xs" hi - ?? lgePermutation `at` (Inst @"xs" (quickSort hi), Inst @"pivot" a, Inst @"ys" hi) + -- Deduce that quickSort hi is all greater than or equal to a + ?? sortIsPermutation `at` Inst @"xs" hi + ?? lgePermutation `at` (Inst @"xs" (quickSort hi), Inst @"pivot" a, Inst @"ys" hi) - -- Finally conclude that the whole reconstruction is non-decreasing - ?? nonDecreasingMerge `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" (quickSort hi)) - =: sTrue - =: qed + -- Finally conclude that the whole reconstruction is non-decreasing + ?? nonDecreasingMerge `at` (Inst @"xs" (quickSort lo), Inst @"pivot" a, Inst @"ys" (quickSort hi)) + =: sTrue + =: qed |] -------------------------------------------------------------------------------------------- @@ -691,10 +686,12 @@ [proofOf unchangedIfNondecreasing] -------------------------------------------------------------------------------------------- - -- | We can display the dependencies in a proof + -- We can display the dependencies in a proof. + -- Note that we do avoid doing this during the + -- dry-run of the proof to avoid duplicate output. -------------------------------------------------------------------------------------------- - liftIO $ do putStrLn "== Proof tree:" - putStr $ showProofTree True qs + unlessDryRun $ liftIO $ do putStrLn "== Proof tree:" + putStr $ showProofTree True qs pure qs diff --git a/Documentation/SBV/Examples/TP/RevAcc.hs b/Documentation/SBV/Examples/TP/RevAcc.hs --- a/Documentation/SBV/Examples/TP/RevAcc.hs +++ b/Documentation/SBV/Examples/TP/RevAcc.hs @@ -52,13 +52,13 @@ -- -- >>> correctness @Integer -- Inductive lemma: revAccCorrect --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. --- Lemma: revCorrect Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. +-- Lemma: revCorrect Q.E.D. -- Functions proven terminating: revAcc, sbv.reverse -- [Proven] revCorrect :: Ɐxs ∷ [Integer] → Bool correctness :: forall a. SymVal a => IO (Proof (Forall "xs" [a] -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Reverse.hs b/Documentation/SBV/Examples/TP/Reverse.hs --- a/Documentation/SBV/Examples/TP/Reverse.hs +++ b/Documentation/SBV/Examples/TP/Reverse.hs @@ -60,15 +60,15 @@ -- -- >>> runTP $ revPreservesLen @Integer -- Inductive lemma (strong): revPreservesLen --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: rev -- [Proven] revPreservesLen :: Ɐxs ∷ [Integer] → Bool revPreservesLen :: forall a. SymVal a => TP (Proof (Forall "xs" [a] -> SBool)) diff --git a/Documentation/SBV/Examples/TP/ShefferStroke.hs b/Documentation/SBV/Examples/TP/ShefferStroke.hs --- a/Documentation/SBV/Examples/TP/ShefferStroke.hs +++ b/Documentation/SBV/Examples/TP/ShefferStroke.hs @@ -142,195 +142,195 @@ -- Axiom: a ⏐ (b ⏐ ﬧb) == ﬧa -- Axiom: ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a) -- Lemma: a | b = b | a --- Step: 1 (ﬧﬧa == a) Q.E.D. --- Step: 2 (ﬧﬧa == a) Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 (ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)) Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 (ﬧﬧa == a) Q.E.D. --- Step: 7 (ﬧﬧa == a) Q.E.D. --- Result: Q.E.D. +-- Step: 1 (ﬧﬧa == a) Q.E.D. +-- Step: 2 (ﬧﬧa == a) Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 (ﬧ(a ⏐ (b ⏐ c)) == (ﬧb ⏐ a) ⏐ (ﬧc ⏐ a)) Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 (ﬧﬧa == a) Q.E.D. +-- Step: 7 (ﬧﬧa == a) Q.E.D. +-- Result: Q.E.D. -- Lemma: a | a′ = b | b′ --- Step: 1 (ﬧﬧa == a) Q.E.D. --- Step: 2 (a ⏐ (b ⏐ ﬧb) == ﬧa) Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 (a ⏐ (b ⏐ ﬧb) == ﬧa) Q.E.D. --- Step: 5 (ﬧﬧa == a) Q.E.D. --- Result: Q.E.D. --- Lemma: a ⊔ b = b ⊔ a Q.E.D. --- Lemma: a ⊓ b = b ⊓ a Q.E.D. --- Lemma: a ⊔ ⲳ = a Q.E.D. --- Lemma: a ⊓ т = a Q.E.D. --- Lemma: a ⊔ (b ⊓ c) = (a ⊔ b) ⊓ (a ⊔ c) Q.E.D. --- Lemma: a ⊓ (b ⊔ c) = (a ⊓ b) ⊔ (a ⊓ c) Q.E.D. --- Lemma: a ⊔ aᶜ = т Q.E.D. --- Lemma: a ⊓ aᶜ = ⲳ Q.E.D. +-- Step: 1 (ﬧﬧa == a) Q.E.D. +-- Step: 2 (a ⏐ (b ⏐ ﬧb) == ﬧa) Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 (a ⏐ (b ⏐ ﬧb) == ﬧa) Q.E.D. +-- Step: 5 (ﬧﬧa == a) Q.E.D. +-- Result: Q.E.D. +-- Lemma: a ⊔ b = b ⊔ a Q.E.D. +-- Lemma: a ⊓ b = b ⊓ a Q.E.D. +-- Lemma: a ⊔ ⲳ = a Q.E.D. +-- Lemma: a ⊓ т = a Q.E.D. +-- Lemma: a ⊔ (b ⊓ c) = (a ⊔ b) ⊓ (a ⊔ c) Q.E.D. +-- Lemma: a ⊓ (b ⊔ c) = (a ⊓ b) ⊔ (a ⊓ c) Q.E.D. +-- Lemma: a ⊔ aᶜ = т Q.E.D. +-- Lemma: a ⊓ aᶜ = ⲳ Q.E.D. -- Lemma: a ⊔ т = т --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Lemma: a ⊓ ⲳ = ⲳ --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Lemma: a ⊔ (a ⊓ b) = a --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Lemma: a ⊓ (a ⊔ b) = a --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Lemma: a ⊓ a = a --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Lemma: a ⊔ a' = т → a ⊓ a' = ⲳ → a' = aᶜ --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Step: 8 Q.E.D. --- Step: 9 Q.E.D. --- Step: 10 Q.E.D. --- Step: 11 Q.E.D. --- Result: Q.E.D. --- Lemma: aᶜᶜ = a Q.E.D. --- Lemma: aᶜ = bᶜ → a = b Q.E.D. --- Lemma: a ⊔ bᶜ = т → a ⊓ bᶜ = ⲳ → a = b Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Step: 8 Q.E.D. +-- Step: 9 Q.E.D. +-- Step: 10 Q.E.D. +-- Step: 11 Q.E.D. +-- Result: Q.E.D. +-- Lemma: aᶜᶜ = a Q.E.D. +-- Lemma: aᶜ = bᶜ → a = b Q.E.D. +-- Lemma: a ⊔ bᶜ = т → a ⊓ bᶜ = ⲳ → a = b Q.E.D. -- Lemma: a ⊔ (aᶜ ⊔ b) = т --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Lemma: a ⊓ (aᶜ ⊓ b) = ⲳ --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. --- Lemma: (a ⊔ b)ᶜ = aᶜ ⊓ bᶜ Q.E.D. --- Lemma: (a ⨅ b)ᶜ = aᶜ ⨆ bᶜ Q.E.D. --- Lemma: (a ⊔ (b ⊔ c)) ⊔ aᶜ = т Q.E.D. --- Lemma: b ⊓ (a ⊔ (b ⊔ c)) = b Q.E.D. --- Lemma: b ⊔ (a ⊓ (b ⊓ c)) = b Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. +-- Lemma: (a ⊔ b)ᶜ = aᶜ ⊓ bᶜ Q.E.D. +-- Lemma: (a ⨅ b)ᶜ = aᶜ ⨆ bᶜ Q.E.D. +-- Lemma: (a ⊔ (b ⊔ c)) ⊔ aᶜ = т Q.E.D. +-- Lemma: b ⊓ (a ⊔ (b ⊔ c)) = b Q.E.D. +-- Lemma: b ⊔ (a ⊓ (b ⊓ c)) = b Q.E.D. -- Lemma: (a ⊔ (b ⊔ c)) ⊔ bᶜ = т --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Step: 8 Q.E.D. --- Step: 9 Q.E.D. --- Result: Q.E.D. --- Lemma: (a ⊔ (b ⊔ c)) ⊔ cᶜ = т Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Step: 8 Q.E.D. +-- Step: 9 Q.E.D. +-- Result: Q.E.D. +-- Lemma: (a ⊔ (b ⊔ c)) ⊔ cᶜ = т Q.E.D. -- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ a = ⲳ --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Step: 8 Q.E.D. --- Step: 9 Q.E.D. --- Result: Q.E.D. --- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ b = ⲳ Q.E.D. --- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ c = ⲳ Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Step: 8 Q.E.D. +-- Step: 9 Q.E.D. +-- Result: Q.E.D. +-- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ b = ⲳ Q.E.D. +-- Lemma: (a ⊔ b ⊔ c)ᶜ ⊓ c = ⲳ Q.E.D. -- Lemma: (a ⊔ (b ⊔ c)) ⊔ ((a ⊔ b) ⊔ c)ᶜ = т --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Step: 8 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Step: 8 Q.E.D. +-- Result: Q.E.D. -- Lemma: (a ⊔ (b ⊔ c)) ⊓ ((a ⊔ b) ⊔ c)ᶜ = ⲳ --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Step: 8 Q.E.D. --- Step: 9 Q.E.D. --- Step: 10 Q.E.D. --- Step: 11 Q.E.D. --- Step: 12 Q.E.D. --- Result: Q.E.D. --- Lemma: a ⊔ (b ⊔ c) = (a ⊔ b) ⊔ c Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Step: 8 Q.E.D. +-- Step: 9 Q.E.D. +-- Step: 10 Q.E.D. +-- Step: 11 Q.E.D. +-- Step: 12 Q.E.D. +-- Result: Q.E.D. +-- Lemma: a ⊔ (b ⊔ c) = (a ⊔ b) ⊔ c Q.E.D. -- Lemma: a ⊓ (b ⊓ c) = (a ⊓ b) ⊓ c --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: a ≤ b → b ≤ a → a = b --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Lemma: a ≤ a Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: a ≤ a Q.E.D. -- Lemma: a ≤ b → b ≤ c → a ≤ c --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. --- Lemma: a < b ↔ a ≤ b ∧ ¬b ≤ a Q.E.D. --- Lemma: a ≤ a ⊔ b Q.E.D. --- Lemma: b ≤ a ⊔ b Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. +-- Lemma: a < b ↔ a ≤ b ∧ ¬b ≤ a Q.E.D. +-- Lemma: a ≤ a ⊔ b Q.E.D. +-- Lemma: b ≤ a ⊔ b Q.E.D. -- Lemma: a ≤ c → b ≤ c → a ⊔ b ≤ c --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. --- Lemma: a ⊓ b ≤ a Q.E.D. --- Lemma: a ⊓ b ≤ b Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. +-- Lemma: a ⊓ b ≤ a Q.E.D. +-- Lemma: a ⊓ b ≤ b Q.E.D. -- Lemma: a ≤ b → a ≤ c → a ≤ b ⊓ c --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Lemma: (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z Q.E.D. --- Lemma: x ⊓ xᶜ ≤ ⊥ Q.E.D. --- Lemma: ⊤ ≤ x ⊔ xᶜ Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: (x ⊔ y) ⊓ (x ⊔ z) ≤ x ⊔ y ⊓ z Q.E.D. +-- Lemma: x ⊓ xᶜ ≤ ⊥ Q.E.D. +-- Lemma: ⊤ ≤ x ⊔ xᶜ Q.E.D. -- Lemma: a ≤ ⊤ --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Lemma: ⊥ ≤ a --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. --- Lemma: x \ y = x ⊓ yᶜ Q.E.D. --- Lemma: x ⇨ y = y ⊔ xᶜ Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. +-- Lemma: x \ y = x ⊓ yᶜ Q.E.D. +-- Lemma: x ⇨ y = y ⊔ xᶜ Q.E.D. -- BooleanAlgebraProof { -- le_refl : [Proven] a ≤ a :: Ɐa ∷ Stroke → Bool -- le_trans : [Proven] a ≤ b → b ≤ c → a ≤ c :: Ɐa ∷ Stroke → Ɐb ∷ Stroke → Ɐc ∷ Stroke → Bool @@ -351,7 +351,7 @@ -- himp_eq : [Proven] x ⇨ y = y ⊔ xᶜ :: Ɐx ∷ Stroke → Ɐy ∷ Stroke → Bool -- } shefferBooleanAlgebra :: IO BooleanAlgebraProof -shefferBooleanAlgebra = runTPWith (tpRibbon 60 z3) $ do +shefferBooleanAlgebra = runTP $ do -- shorthand let p = proofOf diff --git a/Documentation/SBV/Examples/TP/SortHelpers.hs b/Documentation/SBV/Examples/TP/SortHelpers.hs --- a/Documentation/SBV/Examples/TP/SortHelpers.hs +++ b/Documentation/SBV/Examples/TP/SortHelpers.hs @@ -50,7 +50,7 @@ -- | The tail of a non-decreasing list is non-decreasing. We have: -- -- >>> runTP $ nonDecrTail @Integer --- Lemma: nonDecrTail Q.E.D. +-- Lemma: nonDecrTail Q.E.D. -- Functions proven terminating: nonDecreasing -- [Proven] nonDecrTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool nonDecrTail :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool)) @@ -61,7 +61,7 @@ -- | If we insert an element that is less than the head of a nonDecreasing list, it remains nondecreasing. We have: -- -- >>> runTP $ nonDecrIns @Integer --- Lemma: nonDecrInsert Q.E.D. +-- Lemma: nonDecrInsert Q.E.D. -- Functions proven terminating: nonDecreasing -- [Proven] nonDecrInsert :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Bool nonDecrIns :: forall a. (OrdSymbolic (SBV a), SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> SBool)) @@ -77,34 +77,34 @@ -- -- >>> runTP $ sublistCorrect @Integer -- Inductive lemma: countNonNeg --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: countElem --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: elemCount --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: sublistCorrect --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] sublistCorrect :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Ɐx ∷ Integer → Bool sublistCorrect :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> Forall "x" a -> SBool)) @@ -126,37 +126,37 @@ -- -- >>> runTP $ sublistElem @Integer -- Inductive lemma: countNonNeg --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: countElem --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: elemCount --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: sublistCorrect --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Lemma: sublistElem --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: count -- [Proven] sublistElem :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool sublistElem :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> Forall "ys" [a] -> SBool)) @@ -174,7 +174,7 @@ -- | If one list is a sublist of another so is its tail. We have: -- -- >>> runTP $ sublistTail @Integer --- Lemma: sublistTail Q.E.D. +-- Lemma: sublistTail Q.E.D. -- Functions proven terminating: count -- [Proven] sublistTail :: Ɐx ∷ Integer → Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool sublistTail :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "x" a -> Forall "xs" [a] -> Forall "ys" [a] -> SBool)) @@ -186,7 +186,7 @@ -- | Permutation implies sublist. We have: -- -- >>> runTP $ sublistIfPerm @Integer --- Lemma: sublistIfPerm Q.E.D. +-- Lemma: sublistIfPerm Q.E.D. -- Functions proven terminating: count -- [Proven] sublistIfPerm :: Ɐxs ∷ [Integer] → Ɐys ∷ [Integer] → Bool sublistIfPerm :: forall a. (Eq a, SymVal a) => TP (Proof (Forall "xs" [a] -> Forall "ys" [a] -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Sqrt2IsIrrational.hs b/Documentation/SBV/Examples/TP/Sqrt2IsIrrational.hs --- a/Documentation/SBV/Examples/TP/Sqrt2IsIrrational.hs +++ b/Documentation/SBV/Examples/TP/Sqrt2IsIrrational.hs @@ -48,15 +48,15 @@ -- -- >>> sqrt2IsIrrational -- Lemma: oddSquaredIsOdd --- Step: 1 Q.E.D. --- Step: 2 (expand square) Q.E.D. --- Result: Q.E.D. --- Lemma: squareEvenImpliesEven Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 (expand square) Q.E.D. +-- Result: Q.E.D. +-- Lemma: squareEvenImpliesEven Q.E.D. -- Lemma: evenSquaredIsMult4 --- Step: 1 Q.E.D. --- Step: 2 (expand square) Q.E.D. --- Result: Q.E.D. --- Lemma: sqrt2IsIrrational Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 (expand square) Q.E.D. +-- Result: Q.E.D. +-- Lemma: sqrt2IsIrrational Q.E.D. -- [Proven] sqrt2IsIrrational :: Bool sqrt2IsIrrational :: IO (Proof SBool) sqrt2IsIrrational = runTP $ do diff --git a/Documentation/SBV/Examples/TP/StrongInduction.hs b/Documentation/SBV/Examples/TP/StrongInduction.hs --- a/Documentation/SBV/Examples/TP/StrongInduction.hs +++ b/Documentation/SBV/Examples/TP/StrongInduction.hs @@ -40,15 +40,15 @@ -- -- >>> oddSequence1 -- Inductive lemma (strong): oddSequence1 --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: seq -- [Proven] oddSequence1 :: Ɐn ∷ Integer → Bool oddSequence1 :: IO (Proof (Forall "n" Integer -> SBool)) @@ -81,29 +81,29 @@ -- We have: -- -- >>> oddSequence2 --- Lemma: oddSequence_0 Q.E.D. --- Lemma: oddSequence_1 Q.E.D. +-- Lemma: oddSequence_0 Q.E.D. +-- Lemma: oddSequence_1 Q.E.D. -- Inductive lemma (strong): oddSequence_sNp2 --- Step: Measure is non-negative Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 (simplify) Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 (simplify) Q.E.D. --- Step: 6 Q.E.D. --- Result: Q.E.D. +-- Step: Measure is non-negative Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 (simplify) Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 (simplify) Q.E.D. +-- Step: 6 Q.E.D. +-- Result: Q.E.D. -- Lemma: oddSequence2 -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: seq -- [Proven] oddSequence2 :: Ɐn ∷ Integer → Bool oddSequence2 :: IO (Proof (Forall "n" Integer -> SBool)) -oddSequence2 = runTPWith (tpRibbon 50 z3) $ do +oddSequence2 = runTP $ do let s :: SInteger -> SInteger s = smtFunction "seq" $ \n -> [sCase| n of @@ -180,7 +180,7 @@ -- -- >>> won'tProve2 `catch` (\(_ :: SomeException) -> pure ()) -- Inductive lemma (strong): badLength --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 -- *** Failed to prove badLength.1. -- Falsifiable. Counter-example: @@ -271,24 +271,24 @@ -- -- >>> sumHalves -- Inductive lemma: sumAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma (strong): sumHalves --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (3 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.3.4 Q.E.D. --- Step: 1.3.5 Q.E.D. --- Step: 1.3.6 (simplify) Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.3.4 Q.E.D. +-- Step: 1.3.5 Q.E.D. +-- Step: 1.3.6 (simplify) Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: halvingSum, sbv.foldr -- [Proven] sumHalves :: Ɐxs ∷ [Integer] → Bool sumHalves :: IO (Proof (Forall "xs" [Integer] -> SBool)) diff --git a/Documentation/SBV/Examples/TP/SumReverse.hs b/Documentation/SBV/Examples/TP/SumReverse.hs --- a/Documentation/SBV/Examples/TP/SumReverse.hs +++ b/Documentation/SBV/Examples/TP/SumReverse.hs @@ -37,21 +37,21 @@ -- -- >>> revSum @Integer -- Inductive lemma: sumAppend --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 (associativity) Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 (associativity) Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Inductive lemma: sumReverse --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 (commutativity) Q.E.D. --- Step: 5 Q.E.D. --- Result: Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 (commutativity) Q.E.D. +-- Step: 5 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: sbv.foldr, sbv.reverse -- [Proven] sumReverse :: Ɐxs ∷ [Integer] → Bool revSum :: forall a. (SymVal a, Num (SBV a)) => IO (Proof (Forall "xs" [a] -> SBool)) diff --git a/Documentation/SBV/Examples/TP/Tao.hs b/Documentation/SBV/Examples/TP/Tao.hs --- a/Documentation/SBV/Examples/TP/Tao.hs +++ b/Documentation/SBV/Examples/TP/Tao.hs @@ -49,7 +49,7 @@ -- We have: -- -- >>> tao @T (uninterpret "op") --- Lemma: tao Q.E.D. +-- Lemma: tao Q.E.D. -- [Proven] tao :: Bool tao :: forall a. SymVal a => (SBV a -> SBV a -> SBV a) -> IO (Proof SBool) tao op = runTP $ diff --git a/Documentation/SBV/Examples/TP/TautologyChecker.hs b/Documentation/SBV/Examples/TP/TautologyChecker.hs --- a/Documentation/SBV/Examples/TP/TautologyChecker.hs +++ b/Documentation/SBV/Examples/TP/TautologyChecker.hs @@ -69,7 +69,7 @@ -- | \(\mathit{ifDepth}(f) \geq 0\) -- -- >>> runTP ifDepthNonNeg --- Lemma: ifDepthNonNeg Q.E.D. +-- Lemma: ifDepthNonNeg Q.E.D. -- Functions proven terminating: ifDepth -- [Proven] ifDepthNonNeg :: Ɐf ∷ Formula → Bool ifDepthNonNeg :: TP (Proof (Forall "f" Formula -> SBool)) @@ -86,7 +86,7 @@ -- | \(\mathit{ifComplexity}(f) > 0\) -- -- >>> runTP ifComplexityPos --- Lemma: ifComplexityPos Q.E.D. +-- Lemma: ifComplexityPos Q.E.D. -- Functions proven terminating: ifComplexity -- [Proven] ifComplexityPos :: Ɐf ∷ Formula → Bool ifComplexityPos :: TP (Proof (Forall "f" Formula -> SBool)) @@ -97,10 +97,10 @@ -- \(\mathit{ifComplexity}(c) < \mathit{ifComplexity}(\mathit{If}(c, l, r)) \land \mathit{ifComplexity}(l) < \mathit{ifComplexity}(\mathit{If}(c, l, r)) \land \mathit{ifComplexity}(r) < \mathit{ifComplexity}(\mathit{If}(c, l, r))\) -- -- >>> runTP ifComplexitySmaller --- Lemma: ifComplexityPos Q.E.D. +-- Lemma: ifComplexityPos Q.E.D. -- Lemma: ifComplexitySmaller --- Step: 1 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ifComplexity -- [Proven] ifComplexitySmaller :: Ɐc ∷ Formula → Ɐl ∷ Formula → Ɐr ∷ Formula → Bool ifComplexitySmaller :: TP (Proof (Forall "c" Formula -> Forall "l" Formula -> Forall "r" Formula -> SBool)) @@ -164,16 +164,16 @@ -- \(\mathit{ifComplexity}(\mathit{If}(p, \mathit{If}(q, l, r), \mathit{If}(s, l, r))) = \mathit{ifComplexity}(\mathit{If}(\mathit{If}(p, q, s), l, r))\) -- -- >>> runTP normalizePreservesComplexity --- Lemma: helper Q.E.D. +-- Lemma: helper Q.E.D. -- Lemma: normalizePreservesComplexity --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Step: 5 Q.E.D. --- Step: 6 Q.E.D. --- Step: 7 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Step: 5 Q.E.D. +-- Step: 6 Q.E.D. +-- Step: 7 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ifComplexity -- [Proven] normalizePreservesComplexity :: Ɐp ∷ Formula → Ɐq ∷ Formula → Ɐs ∷ Formula → Ɐl ∷ Formula → Ɐr ∷ Formula → Bool normalizePreservesComplexity :: TP (Proof (Forall "p" Formula -> Forall "q" Formula -> Forall "s" Formula -> Forall "l" Formula -> Forall "r" Formula -> SBool)) @@ -244,7 +244,7 @@ -- | Adding a binding preserves existing assignments. -- -- >>> runTP isAssignedExtends --- Lemma: isAssignedExtends Q.E.D. +-- Lemma: isAssignedExtends Q.E.D. -- Functions proven terminating: isAssigned -- [Proven] isAssignedExtends :: Ɐi ∷ Integer → Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool isAssignedExtends :: TP (Proof (Forall "i" Integer -> Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool)) @@ -255,7 +255,7 @@ -- | Looking up a variable in extended bindings: if already assigned, value is preserved. -- -- >>> runTP lookUpExtends --- Lemma: lookUpExtends Q.E.D. +-- Lemma: lookUpExtends Q.E.D. -- Functions proven terminating: isAssigned, lookUp -- [Proven] lookUpExtends :: Ɐi ∷ Integer → Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool lookUpExtends :: TP (Proof (Forall "i" Integer -> Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool)) @@ -267,7 +267,7 @@ -- | Looking up a variable that was just added returns the added value. -- -- >>> runTP lookUpSame --- Lemma: lookUpSame Q.E.D. +-- Lemma: lookUpSame Q.E.D. -- Functions proven terminating: lookUp -- [Proven] lookUpSame :: Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool lookUpSame :: TP (Proof (Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool)) @@ -276,7 +276,7 @@ -- | Adding a binding for a variable makes it assigned. -- -- >>> runTP isAssignedSame --- Lemma: isAssignedSame Q.E.D. +-- Lemma: isAssignedSame Q.E.D. -- Functions proven terminating: isAssigned -- [Proven] isAssignedSame :: Ɐn ∷ Integer → Ɐv ∷ Bool → Ɐbs ∷ [Binding] → Bool isAssignedSame :: TP (Proof (Forall "n" Integer -> Forall "v" Bool -> Forall "bs" [Binding] -> SBool)) @@ -338,14 +338,14 @@ -- -- >>> runTP lookUpStable -- Inductive lemma: lookUpStable --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: isAssigned, lookUp -- [Proven] lookUpStable :: Ɐa ∷ [Binding] → Ɐx ∷ Integer → Ɐb ∷ [Binding] → Bool lookUpStable :: TP (Proof (Forall "a" [Binding] -> Forall "x" Integer -> Forall "b" [Binding] -> SBool)) @@ -369,13 +369,13 @@ -- -- >>> runTP trueIsAssigned -- Inductive lemma: trueIsAssigned --- Step: Base Q.E.D. +-- Step: Base Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: isAssigned, lookUp -- [Proven] trueIsAssigned :: Ɐa ∷ [Binding] → Ɐx ∷ Integer → Bool trueIsAssigned :: TP (Proof (Forall "a" [Binding] -> Forall "x" Integer -> SBool)) @@ -453,7 +453,7 @@ -- | Key soundness lemma: If a normalized formula is a tautology under bindings @b@, -- then it evaluates to true under @b ++ a@ for any @a@. -- --- >>> runTPWith (tpRibbon 50 cvc5) tautologyImpliesEval +-- >>> runTPWith cvc5 tautologyImpliesEval -- Lemma: ifComplexityPos Q.E.D. -- Lemma: ifComplexitySmaller Q.E.D. -- Lemma: lookUpStable Q.E.D. @@ -605,28 +605,28 @@ -- -- Normalization produces normalized formulas. -- --- >>> runTPWith (tpRibbon 50 z3) normalizeCorrect --- Lemma: ifComplexityPos Q.E.D. --- Lemma: ifComplexitySmaller Q.E.D. --- Lemma: normalizePreservesComplexity Q.E.D. --- Lemma: ifDepthNonNeg Q.E.D. +-- >>> runTP normalizeCorrect +-- Lemma: ifComplexityPos Q.E.D. +-- Lemma: ifComplexitySmaller Q.E.D. +-- Lemma: normalizePreservesComplexity Q.E.D. +-- Lemma: ifDepthNonNeg Q.E.D. -- Inductive lemma (strong): normalizeCorrect --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. -- Step: 1.4 (2 way case split) --- Step: 1.4.1.1 Q.E.D. --- Step: 1.4.1.2 Q.E.D. --- Step: 1.4.2.1 Q.E.D. --- Step: 1.4.2.2 Q.E.D. --- Step: 1.4.2.3 Q.E.D. --- Step: 1.4.2.4 Q.E.D. --- Step: 1.4.2.5 Q.E.D. --- Step: 1.4.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.4.1.1 Q.E.D. +-- Step: 1.4.1.2 Q.E.D. +-- Step: 1.4.2.1 Q.E.D. +-- Step: 1.4.2.2 Q.E.D. +-- Step: 1.4.2.3 Q.E.D. +-- Step: 1.4.2.4 Q.E.D. +-- Step: 1.4.2.5 Q.E.D. +-- Step: 1.4.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ifComplexity, ifDepth, isNormal, normalize -- [Proven] normalizeCorrect :: Ɐf ∷ Formula → Bool normalizeCorrect :: TP (Proof (Forall "f" Formula -> SBool)) @@ -675,19 +675,19 @@ -- -- Normalizing a normalized formula is the identity. -- --- >>> runTPWith (tpRibbon 50 z3) normalizeSame --- Lemma: ifComplexityPos Q.E.D. --- Lemma: ifComplexitySmaller Q.E.D. +-- >>> runTP normalizeSame +-- Lemma: ifComplexityPos Q.E.D. +-- Lemma: ifComplexitySmaller Q.E.D. -- Inductive lemma (strong): normalizeSame --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. --- Step: 1.4.1 Q.E.D. --- Step: 1.4.2 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. +-- Step: 1.4.1 Q.E.D. +-- Step: 1.4.2 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: ifComplexity, isNormal, normalize -- [Proven] normalizeSame :: Ɐf ∷ Formula → Bool normalizeSame :: TP (Proof (Forall "f" Formula -> SBool)) @@ -719,25 +719,25 @@ -- -- Normalization preserves semantics. -- --- >>> runTPWith (tpRibbon 50 z3) normalizeRespectsTruth --- Lemma: ifComplexityPos Q.E.D. --- Lemma: ifComplexitySmaller Q.E.D. --- Lemma: normalizePreservesComplexity Q.E.D. --- Lemma: ifDepthNonNeg Q.E.D. +-- >>> runTP normalizeRespectsTruth +-- Lemma: ifComplexityPos Q.E.D. +-- Lemma: ifComplexitySmaller Q.E.D. +-- Lemma: normalizePreservesComplexity Q.E.D. +-- Lemma: ifDepthNonNeg Q.E.D. -- Inductive lemma (strong): normalizeRespectsTruth --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. -- Step: 1.4 (2 way case split) --- Step: 1.4.1 Q.E.D. --- Step: 1.4.2.1 Q.E.D. --- Step: 1.4.2.2 Q.E.D. --- Step: 1.4.2.3 Q.E.D. --- Step: 1.4.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.4.1 Q.E.D. +-- Step: 1.4.2.1 Q.E.D. +-- Step: 1.4.2.2 Q.E.D. +-- Step: 1.4.2.3 Q.E.D. +-- Step: 1.4.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: eval, ifComplexity, ifDepth, lookUp, normalize -- [Proven] normalizeRespectsTruth :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Bool normalizeRespectsTruth :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> SBool)) @@ -787,13 +787,13 @@ -- to true under any binding environment. This is the soundness theorem. -- -- >>> runTP soundness --- Lemma: tautologyImpliesEval Q.E.D. --- Lemma: normalizeRespectsTruth Q.E.D. --- Lemma: normalizeCorrect Q.E.D. +-- Lemma: tautologyImpliesEval Q.E.D. +-- Lemma: normalizeRespectsTruth Q.E.D. +-- Lemma: normalizeCorrect Q.E.D. -- Lemma: soundness --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: eval, ifComplexity, ifDepth, isAssigned, isNormal, isTautology', lookUp, normalize -- [Proven] soundness :: Ɐf ∷ Formula → Ɐbindings ∷ [Binding] → Bool soundness :: TP (Proof (Forall "f" Formula -> Forall "bindings" [Binding] -> SBool)) @@ -856,18 +856,18 @@ -- | If a normalized formula is not a tautology, then falsify' returns falsified = true. -- --- >>> runTPWith (tpRibbon 50 cvc5) nonTautIsFalsified --- Lemma: ifComplexityPos Q.E.D. --- Lemma: ifComplexitySmaller Q.E.D. +-- >>> runTPWith cvc5 nonTautIsFalsified +-- Lemma: ifComplexityPos Q.E.D. +-- Lemma: ifComplexitySmaller Q.E.D. -- Inductive lemma (strong): nonTautIsFalsified --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. --- Step: 1.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. +-- Step: 1.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: eval, falsify', ifComplexity, isAssigned, isNormal, isTautology', lookUp -- [Proven] nonTautIsFalsified :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Bool nonTautIsFalsified :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> SBool)) @@ -898,20 +898,20 @@ -- | If a variable is assigned in the input bindings and falsify' succeeds, -- the lookup value is preserved in the output bindings. -- --- >>> runTPWith (tpRibbon 50 cvc5) falsifyExtendsBindings --- Lemma: ifComplexityPos Q.E.D. --- Lemma: ifComplexitySmaller Q.E.D. --- Lemma: isAssignedExtends Q.E.D. --- Lemma: lookUpExtends Q.E.D. +-- >>> runTPWith cvc5 falsifyExtendsBindings +-- Lemma: ifComplexityPos Q.E.D. +-- Lemma: ifComplexitySmaller Q.E.D. +-- Lemma: isAssignedExtends Q.E.D. +-- Lemma: lookUpExtends Q.E.D. -- Inductive lemma (strong): falsifyExtendsBindings --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2 Q.E.D. --- Step: 1.3 Q.E.D. --- Step: 1.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2 Q.E.D. +-- Step: 1.3 Q.E.D. +-- Step: 1.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: eval, falsify', ifComplexity, isAssigned, lookUp -- [Proven] falsifyExtendsBindings :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Ɐi ∷ Integer → Bool falsifyExtendsBindings :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> Forall "i" Integer -> SBool)) @@ -955,41 +955,41 @@ -- | If falsify' returns falsified = true, then evaluating the formula -- with the returned bindings gives false. -- --- >>> runTPWith (tpRibbon 50 cvc5) falsifyFalsifies --- Lemma: ifComplexityPos Q.E.D. --- Lemma: ifComplexitySmaller Q.E.D. --- Lemma: falsifyExtendsBindings Q.E.D. --- Lemma: lookUpSame Q.E.D. --- Lemma: isAssignedSame Q.E.D. +-- >>> runTPWith cvc5 falsifyFalsifies +-- Lemma: ifComplexityPos Q.E.D. +-- Lemma: ifComplexitySmaller Q.E.D. +-- Lemma: falsifyExtendsBindings Q.E.D. +-- Lemma: lookUpSame Q.E.D. +-- Lemma: isAssignedSame Q.E.D. -- Inductive lemma (strong): falsifyFalsifies --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (4 way case split) --- Step: 1.1.1 Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.1.3 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.3.1 Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. +-- Step: 1.1.1 Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.1.3 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.3.1 Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. -- Step: 1.4 (4 way case split) --- Step: 1.4.1 Q.E.D. --- Step: 1.4.2 Q.E.D. +-- Step: 1.4.1 Q.E.D. +-- Step: 1.4.2 Q.E.D. -- Step: 1.4.3 (2 way case split) -- Step: 1.4.3.1 (2 way case split) --- Step: 1.4.3.1.1 Q.E.D. --- Step: 1.4.3.1.2 Q.E.D. --- Step: 1.4.3.1.Completeness Q.E.D. +-- Step: 1.4.3.1.1 Q.E.D. +-- Step: 1.4.3.1.2 Q.E.D. +-- Step: 1.4.3.1.Completeness Q.E.D. -- Step: 1.4.3.2 (2 way case split) --- Step: 1.4.3.2.1 Q.E.D. --- Step: 1.4.3.2.2 Q.E.D. --- Step: 1.4.3.2.Completeness Q.E.D. --- Step: 1.4.3.Completeness Q.E.D. --- Step: 1.4.4 Q.E.D. --- Step: 1.4.Completeness Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.4.3.2.1 Q.E.D. +-- Step: 1.4.3.2.2 Q.E.D. +-- Step: 1.4.3.2.Completeness Q.E.D. +-- Step: 1.4.3.Completeness Q.E.D. +-- Step: 1.4.4 Q.E.D. +-- Step: 1.4.Completeness Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: eval, falsify', ifComplexity, isAssigned, isNormal, lookUp -- [Proven] falsifyFalsifies :: Ɐf ∷ Formula → Ɐbs ∷ [Binding] → Bool falsifyFalsifies :: TP (Proof (Forall "f" Formula -> Forall "bs" [Binding] -> SBool)) @@ -1082,10 +1082,10 @@ -- evaluating its normalization with falsify's bindings gives false. -- -- >>> runTPWith cvc5 completenessHelper --- Lemma: falsifyFalsifies Q.E.D. --- Lemma: nonTautIsFalsified Q.E.D. --- Lemma: normalizeCorrect Q.E.D. --- Lemma: completenessHelper Q.E.D. +-- Lemma: falsifyFalsifies Q.E.D. +-- Lemma: nonTautIsFalsified Q.E.D. +-- Lemma: normalizeCorrect Q.E.D. +-- Lemma: completenessHelper Q.E.D. -- Functions proven terminating: -- eval, falsify', ifComplexity, ifDepth, isAssigned, isNormal, isTautology', lookUp, normalize -- [Proven] completenessHelper :: Ɐf ∷ Formula → Bool @@ -1108,9 +1108,9 @@ -- This is the completeness theorem. -- -- >>> runTPWith cvc5 completeness --- Lemma: completenessHelper Q.E.D. --- Lemma: normalizeRespectsTruth Q.E.D. --- Lemma: completeness Q.E.D. +-- Lemma: completenessHelper Q.E.D. +-- Lemma: normalizeRespectsTruth Q.E.D. +-- Lemma: completeness Q.E.D. -- Functions proven terminating: -- eval, falsify', ifComplexity, ifDepth, isAssigned, isNormal, isTautology', lookUp, normalize -- [Proven] completeness :: Ɐf ∷ Formula → Bool diff --git a/Documentation/SBV/Examples/TP/UpDown.hs b/Documentation/SBV/Examples/TP/UpDown.hs --- a/Documentation/SBV/Examples/TP/UpDown.hs +++ b/Documentation/SBV/Examples/TP/UpDown.hs @@ -71,19 +71,19 @@ -- | Prove that @reverse (down n)@ is the same as @up n@ -- -- >>> runTP upDown --- Lemma: n2iNonNeg Q.E.D. --- Lemma: revCons Q.E.D. +-- Lemma: n2iNonNeg Q.E.D. +-- Lemma: revCons Q.E.D. -- Inductive lemma (strong): upDownGen --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (2 way case split) --- Step: 1.1 Q.E.D. --- Step: 1.2.1 Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.2.4 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. --- Lemma: upDown Q.E.D. +-- Step: 1.1 Q.E.D. +-- Step: 1.2.1 Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.2.4 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. +-- Lemma: upDown Q.E.D. -- Functions proven terminating: down, n2i, sbv.reverse, up -- [Proven] upDown :: Ɐn ∷ Nat → Bool upDown :: TP (Proof (Forall "n" Nat -> SBool)) diff --git a/Documentation/SBV/Examples/TP/VM.hs b/Documentation/SBV/Examples/TP/VM.hs --- a/Documentation/SBV/Examples/TP/VM.hs +++ b/Documentation/SBV/Examples/TP/VM.hs @@ -194,77 +194,77 @@ -- -- >>> runTP (correctness @String @Integer) -- Inductive lemma: runSeq --- Step: Base Q.E.D. --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Result: Q.E.D. --- Lemma: runOne Q.E.D. +-- Step: Base Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Result: Q.E.D. +-- Lemma: runOne Q.E.D. -- Lemma: runTwo --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Result: Q.E.D. --- Lemma: runMul Q.E.D. --- Lemma: measureNonNeg Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Result: Q.E.D. +-- Lemma: runMul Q.E.D. +-- Lemma: measureNonNeg Q.E.D. -- Inductive lemma (strong): helper --- Step: Measure is non-negative Q.E.D. +-- Step: Measure is non-negative Q.E.D. -- Step: 1 (7 way case split) --- Step: 1.1.1 (case Var) Q.E.D. --- Step: 1.1.2 Q.E.D. --- Step: 1.2.1 (case Con) Q.E.D. --- Step: 1.2.2 Q.E.D. --- Step: 1.2.3 Q.E.D. --- Step: 1.3.1 (case Sqr) Q.E.D. --- Step: 1.3.2 Q.E.D. --- Step: 1.3.3 Q.E.D. --- Step: 1.3.4 Q.E.D. --- Step: 1.3.5 Q.E.D. --- Step: 1.3.6 Q.E.D. --- Step: 1.3.7 Q.E.D. --- Step: 1.4.1 (case Inc) Q.E.D. --- Step: 1.4.2 Q.E.D. --- Step: 1.4.3 Q.E.D. --- Step: 1.4.4 Q.E.D. --- Step: 1.4.5 Q.E.D. --- Step: 1.4.6 Q.E.D. --- Step: 1.4.7 Q.E.D. --- Step: 1.5.1 (case sAdd) Q.E.D. --- Step: 1.5.2 Q.E.D. --- Step: 1.5.3 Q.E.D. --- Step: 1.5.4 Q.E.D. --- Step: 1.5.5 Q.E.D. --- Step: 1.5.6 Q.E.D. --- Step: 1.5.7 Q.E.D. --- Step: 1.5.8 Q.E.D. --- Step: 1.5.9 Q.E.D. --- Step: 1.6.1 (case sMul) Q.E.D. --- Step: 1.6.2 Q.E.D. --- Step: 1.6.3 Q.E.D. --- Step: 1.6.4 Q.E.D. --- Step: 1.6.5 Q.E.D. --- Step: 1.6.6 Q.E.D. --- Step: 1.6.7 Q.E.D. --- Step: 1.6.8 Q.E.D. --- Step: 1.6.9 Q.E.D. --- Step: 1.7.1 (case Let) Q.E.D. --- Step: 1.7.2 Q.E.D. --- Step: 1.7.3 Q.E.D. --- Step: 1.7.4 Q.E.D. --- Step: 1.7.5 Q.E.D. --- Step: 1.7.6 Q.E.D. --- Step: 1.7.7 Q.E.D. --- Step: 1.7.8 Q.E.D. --- Step: 1.7.9 Q.E.D. --- Step: 1.7.10 Q.E.D. --- Step: 1.7.11 Q.E.D. --- Step: 1.Completeness Q.E.D. --- Result: Q.E.D. +-- Step: 1.1.1 (case Var) Q.E.D. +-- Step: 1.1.2 Q.E.D. +-- Step: 1.2.1 (case Con) Q.E.D. +-- Step: 1.2.2 Q.E.D. +-- Step: 1.2.3 Q.E.D. +-- Step: 1.3.1 (case Sqr) Q.E.D. +-- Step: 1.3.2 Q.E.D. +-- Step: 1.3.3 Q.E.D. +-- Step: 1.3.4 Q.E.D. +-- Step: 1.3.5 Q.E.D. +-- Step: 1.3.6 Q.E.D. +-- Step: 1.3.7 Q.E.D. +-- Step: 1.4.1 (case Inc) Q.E.D. +-- Step: 1.4.2 Q.E.D. +-- Step: 1.4.3 Q.E.D. +-- Step: 1.4.4 Q.E.D. +-- Step: 1.4.5 Q.E.D. +-- Step: 1.4.6 Q.E.D. +-- Step: 1.4.7 Q.E.D. +-- Step: 1.5.1 (case sAdd) Q.E.D. +-- Step: 1.5.2 Q.E.D. +-- Step: 1.5.3 Q.E.D. +-- Step: 1.5.4 Q.E.D. +-- Step: 1.5.5 Q.E.D. +-- Step: 1.5.6 Q.E.D. +-- Step: 1.5.7 Q.E.D. +-- Step: 1.5.8 Q.E.D. +-- Step: 1.5.9 Q.E.D. +-- Step: 1.6.1 (case sMul) Q.E.D. +-- Step: 1.6.2 Q.E.D. +-- Step: 1.6.3 Q.E.D. +-- Step: 1.6.4 Q.E.D. +-- Step: 1.6.5 Q.E.D. +-- Step: 1.6.6 Q.E.D. +-- Step: 1.6.7 Q.E.D. +-- Step: 1.6.8 Q.E.D. +-- Step: 1.6.9 Q.E.D. +-- Step: 1.7.1 (case Let) Q.E.D. +-- Step: 1.7.2 Q.E.D. +-- Step: 1.7.3 Q.E.D. +-- Step: 1.7.4 Q.E.D. +-- Step: 1.7.5 Q.E.D. +-- Step: 1.7.6 Q.E.D. +-- Step: 1.7.7 Q.E.D. +-- Step: 1.7.8 Q.E.D. +-- Step: 1.7.9 Q.E.D. +-- Step: 1.7.10 Q.E.D. +-- Step: 1.7.11 Q.E.D. +-- Step: 1.Completeness Q.E.D. +-- Result: Q.E.D. -- Lemma: correctness --- Step: 1 Q.E.D. --- Step: 2 Q.E.D. --- Step: 3 Q.E.D. --- Step: 4 Q.E.D. --- Result: Q.E.D. +-- Step: 1 Q.E.D. +-- Step: 2 Q.E.D. +-- Step: 3 Q.E.D. +-- Step: 4 Q.E.D. +-- Result: Q.E.D. -- Functions proven terminating: compile, exprSize, interpInEnv, sbv.foldl, sbv.lookup -- [Proven] correctness :: Ɐexpr ∷ (Expr String Integer) → Bool correctness :: forall nm val. (SymVal nm, SymVal val, Num (SBV val)) => TP (Proof (Forall "expr" (Expr nm val) -> SBool)) diff --git a/Documentation/SBV/Examples/Transformers/SymbolicEval.hs b/Documentation/SBV/Examples/Transformers/SymbolicEval.hs --- a/Documentation/SBV/Examples/Transformers/SymbolicEval.hs +++ b/Documentation/SBV/Examples/Transformers/SymbolicEval.hs @@ -20,7 +20,6 @@ -- named @x@ and @y@. ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -41,12 +40,8 @@ import Data.SBV.Internals (SBV(SBV), unSBV) import Data.SBV.Trans.Control --- Starting with base 4.16; Data.Bits exports And, which conflicts with the definition here -#if MIN_VERSION_base(4,16,0) +-- Data.Bits exports And, which conflicts with the definition here import Data.SBV.Trans hiding(And) -#else -import Data.SBV.Trans -#endif -- * Allocation of symbolic variables, so we can extract a model later. diff --git a/Documentation/SBV/Examples/Uninterpreted/Deduce.hs b/Documentation/SBV/Examples/Uninterpreted/Deduce.hs --- a/Documentation/SBV/Examples/Uninterpreted/Deduce.hs +++ b/Documentation/SBV/Examples/Uninterpreted/Deduce.hs @@ -64,8 +64,8 @@ p <- free "p" q <- free "q" r <- free "r" - return $ not (p `or` (q `and` r)) - .== (not p `and` not q) `or` (not p `and` not r) + pure $ not (p `or` (q `and` r)) + .== (not p `and` not q) `or` (not p `and` not r) -- Hlint gets confused and thinks the use of @not@ above is from the prelude. Sigh. {- HLint ignore test "Redundant not" -} diff --git a/Documentation/SBV/Examples/Uninterpreted/EUFLogic.hs b/Documentation/SBV/Examples/Uninterpreted/EUFLogic.hs --- a/Documentation/SBV/Examples/Uninterpreted/EUFLogic.hs +++ b/Documentation/SBV/Examples/Uninterpreted/EUFLogic.hs @@ -262,20 +262,20 @@ -- | Interpret an 'Op' into a function over SBV values interpOp :: Op ins out -> InterpM (OpTypes2SBV ins out) interpOp (Op_Unint uop) = state (unintEnsure uop) -interpOp Op_And = return (.&&) -interpOp Op_Or = return (.||) -interpOp Op_Not = return sNot -interpOp (Op_BoolLit b) = return $ fromBool b -interpOp (Op_IfThenElse Repr_Bool) = return ite -interpOp (Op_IfThenElse (Repr_BV BVWidth{})) = return ite -interpOp (Op_Plus BVWidth{}) = return (+) -interpOp (Op_Minus BVWidth{}) = return (-) -interpOp (Op_Times BVWidth{}) = return (*) -interpOp (Op_Abs BVWidth{}) = return abs -interpOp (Op_Signum BVWidth{}) = return signum -interpOp (Op_BVLit BVWidth{} i) = return $ fromInteger i -interpOp (Op_BVEq BVWidth{}) = return (.==) -interpOp (Op_BVLt BVWidth{}) = return (.<) +interpOp Op_And = pure (.&&) +interpOp Op_Or = pure (.||) +interpOp Op_Not = pure sNot +interpOp (Op_BoolLit b) = pure $ fromBool b +interpOp (Op_IfThenElse Repr_Bool) = pure ite +interpOp (Op_IfThenElse (Repr_BV BVWidth{})) = pure ite +interpOp (Op_Plus BVWidth{}) = pure (+) +interpOp (Op_Minus BVWidth{}) = pure (-) +interpOp (Op_Times BVWidth{}) = pure (*) +interpOp (Op_Abs BVWidth{}) = pure abs +interpOp (Op_Signum BVWidth{}) = pure signum +interpOp (Op_BVLit BVWidth{} i) = pure $ fromInteger i +interpOp (Op_BVEq BVWidth{}) = pure (.==) +interpOp (Op_BVLt BVWidth{}) = pure (.<) -- | Interpret an t'EUFExpr' into an SBV value. interpEUFExpr :: EUFExpr tp -> InterpM (Type2SBV tp) @@ -284,7 +284,7 @@ -- | Apply an interpretation of an operator to the interpretations of a sequence of arguments for it. interpApplyEUFExprs :: ghost out -> OpTypes2SBV ins out -> EUFExprs ins -> InterpM (Type2SBV out) -interpApplyEUFExprs _ f EUFExprsNil = return f +interpApplyEUFExprs _ f EUFExprsNil = pure f interpApplyEUFExprs out f (EUFExprsCons e es) = do f_app <- f <$> interpEUFExpr e interpApplyEUFExprs out f_app es diff --git a/Documentation/SBV/Examples/Uninterpreted/Multiply.hs b/Documentation/SBV/Examples/Uninterpreted/Multiply.hs --- a/Documentation/SBV/Examples/Uninterpreted/Multiply.hs +++ b/Documentation/SBV/Examples/Uninterpreted/Multiply.hs @@ -13,7 +13,7 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} +{-# OPTIONS_GHC -Wall -Werror #-} module Documentation.SBV.Examples.Uninterpreted.Multiply where @@ -86,5 +86,6 @@ -- and rest assured that we have a correctly synthesized circuit! synthMul22 :: ConstraintSet synthMul22 = constrain $ \(Forall (a :: SWord8)) (Forall b) -> mul22 (lsb2 a) (lsb2 b) .== lsb2 (a * b) - where lsb2 x = let [x1, x0] = reverse $ take 2 $ blastLE x - in (x1, x0) + where lsb2 x = case blastLE x of + (x0 : x1 : _) -> (x1, x0) + _ -> error "synthMul22: Can't get enough bits from x!" diff --git a/Documentation/SBV/Examples/Uninterpreted/Sort.hs b/Documentation/SBV/Examples/Uninterpreted/Sort.hs --- a/Documentation/SBV/Examples/Uninterpreted/Sort.hs +++ b/Documentation/SBV/Examples/Uninterpreted/Sort.hs @@ -42,7 +42,7 @@ -- f _ = Q_1 t1 :: IO SatResult t1 = sat $ do x <- free "x" - return $ f x ./= x + pure $ f x ./= x -- | This is a variant on the first example, except we also add an axiom -- for the sort, stating that the domain 'Q' has only one element. In this case @@ -53,4 +53,4 @@ t2 :: IO SatResult t2 = sat $ do x <- free "x" constrain $ \(Forall a) (Forall b) -> a .== (b :: SQ) - return $ f x ./= x + pure $ f x ./= x diff --git a/Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs b/Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs --- a/Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs +++ b/Documentation/SBV/Examples/Uninterpreted/UISortAllSat.hs @@ -85,4 +85,4 @@ constrain $ classify l0 .== 0 constrain $ classify l1 .== 1 constrain $ classify l2 .== 2 - return $ l .== l0 .|| l .== l1 .|| l .== l2 + pure $ l .== l0 .|| l .== l1 .|| l .== l2 diff --git a/Documentation/SBV/Examples/WeakestPreconditions/Append.hs b/Documentation/SBV/Examples/WeakestPreconditions/Append.hs --- a/Documentation/SBV/Examples/WeakestPreconditions/Append.hs +++ b/Documentation/SBV/Examples/WeakestPreconditions/Append.hs @@ -89,7 +89,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeAppend :: Program A -imperativeAppend = Program { setup = return () +imperativeAppend = Program { setup = pure () , precondition = const sTrue -- no precondition , program = algorithm , postcondition = postcondition diff --git a/Documentation/SBV/Examples/WeakestPreconditions/Basics.hs b/Documentation/SBV/Examples/WeakestPreconditions/Basics.hs --- a/Documentation/SBV/Examples/WeakestPreconditions/Basics.hs +++ b/Documentation/SBV/Examples/WeakestPreconditions/Basics.hs @@ -90,7 +90,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeInc :: Stmt I -> Stmt I -> Program I -imperativeInc before after = Program { setup = return () +imperativeInc before after = Program { setup = pure () , precondition = pre , program = algorithm before after , postcondition = post diff --git a/Documentation/SBV/Examples/WeakestPreconditions/IntDiv.hs b/Documentation/SBV/Examples/WeakestPreconditions/IntDiv.hs --- a/Documentation/SBV/Examples/WeakestPreconditions/IntDiv.hs +++ b/Documentation/SBV/Examples/WeakestPreconditions/IntDiv.hs @@ -93,7 +93,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeDiv :: Invariant D -> Maybe (WPMeasure D) -> Program D -imperativeDiv inv msr = Program { setup = return () +imperativeDiv inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post diff --git a/Documentation/SBV/Examples/WeakestPreconditions/IntSqrt.hs b/Documentation/SBV/Examples/WeakestPreconditions/IntSqrt.hs --- a/Documentation/SBV/Examples/WeakestPreconditions/IntSqrt.hs +++ b/Documentation/SBV/Examples/WeakestPreconditions/IntSqrt.hs @@ -103,7 +103,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeSqrt :: Invariant S -> Maybe (WPMeasure S) -> Program S -imperativeSqrt inv msr = Program { setup = return () +imperativeSqrt inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post diff --git a/Documentation/SBV/Examples/WeakestPreconditions/Length.hs b/Documentation/SBV/Examples/WeakestPreconditions/Length.hs --- a/Documentation/SBV/Examples/WeakestPreconditions/Length.hs +++ b/Documentation/SBV/Examples/WeakestPreconditions/Length.hs @@ -92,7 +92,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeLength :: Invariant S -> Maybe (WPMeasure S) -> Program S -imperativeLength inv msr = Program { setup = return () +imperativeLength inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post diff --git a/Documentation/SBV/Examples/WeakestPreconditions/Sum.hs b/Documentation/SBV/Examples/WeakestPreconditions/Sum.hs --- a/Documentation/SBV/Examples/WeakestPreconditions/Sum.hs +++ b/Documentation/SBV/Examples/WeakestPreconditions/Sum.hs @@ -100,7 +100,7 @@ -- | A program is the algorithm, together with its pre- and post-conditions. imperativeSum :: Invariant S -> Maybe (WPMeasure S) -> Program S -imperativeSum inv msr = Program { setup = return () +imperativeSum inv msr = Program { setup = pure () , precondition = pre , program = algorithm inv msr , postcondition = post @@ -207,8 +207,8 @@ Following proof obligation failed: ================================== Invariant for loop "i < n" is not maintained by the body: - Before: SumS {n = 2, i = 1, s = 1} - After : SumS {n = 2, i = 2, s = 3} + Before: SumS {n = 3, i = 1, s = 1} + After : SumS {n = 3, i = 2, s = 3} Here, we posed the extra incorrect invariant that @s <= i@ must be maintained, and SBV found us a reachable state that violates the invariant. The /before/ state indeed satisfies @s <= i@, but the /after/ state does not. Note that the proof fails in this case not because the program @@ -224,8 +224,8 @@ Following proof obligation failed: ================================== Measure for loop "i < n" is negative: - State : SumS {n = 3, i = 2, s = 3} - Measure: -1 + State : SumS {n = 7, i = 6, s = 21} + Measure: -5 The failure is pretty obvious in this case: Measure produces a negative value. diff --git a/SBVBenchSuite/BenchSuite/Bench/Bench.hs b/SBVBenchSuite/BenchSuite/Bench/Bench.hs --- a/SBVBenchSuite/BenchSuite/Bench/Bench.hs +++ b/SBVBenchSuite/BenchSuite/Bench/Bench.hs @@ -10,7 +10,7 @@ -- Assessing the overhead of calling solving examples via sbv vs individual solvers ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} diff --git a/SBVBenchSuite/BenchSuite/Existentials/Diophantine.hs b/SBVBenchSuite/BenchSuite/Existentials/Diophantine.hs --- a/SBVBenchSuite/BenchSuite/Existentials/Diophantine.hs +++ b/SBVBenchSuite/BenchSuite/Existentials/Diophantine.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Existentials.Diophantine ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Existentials.Diophantine(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/Misc/NoDiv0.hs b/SBVBenchSuite/BenchSuite/Misc/NoDiv0.hs --- a/SBVBenchSuite/BenchSuite/Misc/NoDiv0.hs +++ b/SBVBenchSuite/BenchSuite/Misc/NoDiv0.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Misc.NoDiv0 ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Misc.NoDiv0(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/Optimization/Instances.hs b/SBVBenchSuite/BenchSuite/Optimization/Instances.hs --- a/SBVBenchSuite/BenchSuite/Optimization/Instances.hs +++ b/SBVBenchSuite/BenchSuite/Optimization/Instances.hs @@ -10,7 +10,7 @@ -- Helper file to provide common orphaned instances for Optimization benchmarks ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Optimization.Instances where diff --git a/SBVBenchSuite/BenchSuite/ProofTools/BMC.hs b/SBVBenchSuite/BenchSuite/ProofTools/BMC.hs --- a/SBVBenchSuite/BenchSuite/ProofTools/BMC.hs +++ b/SBVBenchSuite/BenchSuite/ProofTools/BMC.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.BMC ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.BMC(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs b/SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs --- a/SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs +++ b/SBVBenchSuite/BenchSuite/ProofTools/Fibonacci.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.Fibonacci ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.Fibonacci(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs b/SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs --- a/SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs +++ b/SBVBenchSuite/BenchSuite/ProofTools/Strengthen.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.Strengthen ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.Strengthen(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/ProofTools/Sum.hs b/SBVBenchSuite/BenchSuite/ProofTools/Sum.hs --- a/SBVBenchSuite/BenchSuite/ProofTools/Sum.hs +++ b/SBVBenchSuite/BenchSuite/ProofTools/Sum.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.ProofTools.Sum ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.ProofTools.Sum(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/Queries/Enums.hs b/SBVBenchSuite/BenchSuite/Queries/Enums.hs --- a/SBVBenchSuite/BenchSuite/Queries/Enums.hs +++ b/SBVBenchSuite/BenchSuite/Queries/Enums.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Queries.Enums ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Queries.Enums(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/Queries/GuessNumber.hs b/SBVBenchSuite/BenchSuite/Queries/GuessNumber.hs --- a/SBVBenchSuite/BenchSuite/Queries/GuessNumber.hs +++ b/SBVBenchSuite/BenchSuite/Queries/GuessNumber.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Queries.GuessNumber ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Queries.GuessNumber(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/Transformers/SymbolicEval.hs b/SBVBenchSuite/BenchSuite/Transformers/SymbolicEval.hs --- a/SBVBenchSuite/BenchSuite/Transformers/SymbolicEval.hs +++ b/SBVBenchSuite/BenchSuite/Transformers/SymbolicEval.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Transformers.SymbolicEval ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.Transformers.SymbolicEval(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/Uninterpreted/AUF.hs b/SBVBenchSuite/BenchSuite/Uninterpreted/AUF.hs --- a/SBVBenchSuite/BenchSuite/Uninterpreted/AUF.hs +++ b/SBVBenchSuite/BenchSuite/Uninterpreted/AUF.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Uninterpreted.AUF ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} module BenchSuite.Uninterpreted.AUF(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/Uninterpreted/Deduce.hs b/SBVBenchSuite/BenchSuite/Uninterpreted/Deduce.hs --- a/SBVBenchSuite/BenchSuite/Uninterpreted/Deduce.hs +++ b/SBVBenchSuite/BenchSuite/Uninterpreted/Deduce.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.Uninterpreted.Deduce ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE ScopedTypeVariables #-} module BenchSuite.Uninterpreted.Deduce(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Append.hs b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Append.hs --- a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Append.hs +++ b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Append.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Append ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Append(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs --- a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs +++ b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Basics.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Basics ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE NamedFieldPuns #-} module BenchSuite.WeakestPreconditions.Basics(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Fib.hs b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Fib.hs --- a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Fib.hs +++ b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Fib.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Fig ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Fib(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/WeakestPreconditions/GCD.hs b/SBVBenchSuite/BenchSuite/WeakestPreconditions/GCD.hs --- a/SBVBenchSuite/BenchSuite/WeakestPreconditions/GCD.hs +++ b/SBVBenchSuite/BenchSuite/WeakestPreconditions/GCD.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.GCD ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.GCD(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Instances.hs b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Instances.hs --- a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Instances.hs +++ b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Instances.hs @@ -10,7 +10,7 @@ -- Helper file to provide common orphaned instances for WeakestPrecondition benchmarks ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Instances where diff --git a/SBVBenchSuite/BenchSuite/WeakestPreconditions/IntDiv.hs b/SBVBenchSuite/BenchSuite/WeakestPreconditions/IntDiv.hs --- a/SBVBenchSuite/BenchSuite/WeakestPreconditions/IntDiv.hs +++ b/SBVBenchSuite/BenchSuite/WeakestPreconditions/IntDiv.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.IntDiv ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.IntDiv(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/WeakestPreconditions/IntSqrt.hs b/SBVBenchSuite/BenchSuite/WeakestPreconditions/IntSqrt.hs --- a/SBVBenchSuite/BenchSuite/WeakestPreconditions/IntSqrt.hs +++ b/SBVBenchSuite/BenchSuite/WeakestPreconditions/IntSqrt.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.IntSqrt ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.IntSqrt(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Length.hs b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Length.hs --- a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Length.hs +++ b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Length.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Length ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} module BenchSuite.WeakestPreconditions.Length(benchmarks) where diff --git a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Sum.hs b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Sum.hs --- a/SBVBenchSuite/BenchSuite/WeakestPreconditions/Sum.hs +++ b/SBVBenchSuite/BenchSuite/WeakestPreconditions/Sum.hs @@ -10,7 +10,7 @@ -- Bench suite for Documentation.SBV.Examples.WeakestPreconditions.Sum ----------------------------------------------------------------------------- -{-# OPTIONS_GHC -Wall -Werror -fno-warn-orphans #-} +{-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} {-# LANGUAGE NamedFieldPuns #-} module BenchSuite.WeakestPreconditions.Sum(benchmarks) where diff --git a/SBVBenchSuite/Utils/SBVBenchFramework.hs b/SBVBenchSuite/Utils/SBVBenchFramework.hs --- a/SBVBenchSuite/Utils/SBVBenchFramework.hs +++ b/SBVBenchSuite/Utils/SBVBenchFramework.hs @@ -14,7 +14,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-methods #-} -- for ProvableM orphan +{-# OPTIONS_GHC -Wno-orphans -Wno-missing-methods #-} -- for ProvableM orphan module Utils.SBVBenchFramework ( mkExecString diff --git a/SBVTestSuite/GoldFiles/adt01.gold b/SBVTestSuite/GoldFiles/adt01.gold --- a/SBVTestSuite/GoldFiles/adt01.gold +++ b/SBVTestSuite/GoldFiles/adt01.gold @@ -72,7 +72,7 @@ (KRational (getKRational_1 SBVRational)) )) [GOOD] ; --- literal constants --- -[GOOD] (define-fun s1 () ADT ((as APair ADT) ((as AInt64 ADT) #x0000000000000004) ((as AMaybe ADT) ((as Just (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))) (mkSBVTuple3 0.0 ((_ to_fp 8 24) roundNearestTiesToEven (/ 12.0 1.0)) (mkSBVTuple2 ((as Left (Either Int (_ FloatingPoint 8 24))) 3) (seq.++ (seq.unit false) (seq.unit true)))))))) +[GOOD] (define-fun s1 () ADT ((as APair ADT) ((as AInt64 ADT) #x0000000000000004) ((as AMaybe ADT) ((as Just (Maybe (SBVTuple3 Real (_ FloatingPoint 8 24) (SBVTuple2 (Either Int (_ FloatingPoint 8 24)) (Seq Bool))))) (mkSBVTuple3 0.0 (fp #b0 #b10000010 #b10000000000000000000000) (mkSBVTuple2 ((as Left (Either Int (_ FloatingPoint 8 24))) 3) (seq.++ (seq.unit false) (seq.unit true)))))))) [GOOD] ; --- top level inputs --- [GOOD] (declare-fun s0 () ADT) ; tracks user variable "e" [GOOD] (assert (and (= 1 (str.len (getKChar_1 s0))) diff --git a/SBVTestSuite/GoldFiles/adt05.gold b/SBVTestSuite/GoldFiles/adt05.gold --- a/SBVTestSuite/GoldFiles/adt05.gold +++ b/SBVTestSuite/GoldFiles/adt05.gold @@ -68,7 +68,7 @@ (KRational (getKRational_1 SBVRational)) )) [GOOD] ; --- literal constants --- -[GOOD] (define-fun s4 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 4.0 1.0))) +[GOOD] (define-fun s4 () (_ FloatingPoint 8 24) (fp #b0 #b10000001 #b00000000000000000000000)) [GOOD] ; --- top level inputs --- [GOOD] (declare-fun s0 () ADT) ; tracks user variable "a" [GOOD] (assert (and (= 1 (str.len (getKChar_1 s0))) @@ -104,7 +104,7 @@ [SEND] (get-value (s1)) [RECV] ((s1 (AFloat (fp #b0 #b11111111 #b10000000000000000000000)))) [GOOD] (push 1) -[GOOD] (define-fun s11 () ADT ((as AFloat ADT) ((_ to_fp 8 24) roundNearestTiesToEven (/ 4.0 1.0)))) +[GOOD] (define-fun s11 () ADT ((as AFloat ADT) (fp #b0 #b10000001 #b00000000000000000000000))) [GOOD] (define-fun s12 () Bool (= s0 s11)) [GOOD] (define-fun s13 () Bool (not s12)) [GOOD] (assert s13) diff --git a/SBVTestSuite/GoldFiles/freshVars.gold b/SBVTestSuite/GoldFiles/freshVars.gold --- a/SBVTestSuite/GoldFiles/freshVars.gold +++ b/SBVTestSuite/GoldFiles/freshVars.gold @@ -73,10 +73,10 @@ [GOOD] (define-fun s33 () (_ BitVec 64) #x0000000000000008) [GOOD] (define-fun s34 () Bool (= s11 s33)) [GOOD] (assert s34) -[GOOD] (define-fun s35 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 9.0 1.0))) +[GOOD] (define-fun s35 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00100000000000000000000)) [GOOD] (define-fun s36 () Bool (fp.eq s12 s35)) [GOOD] (assert s36) -[GOOD] (define-fun s37 () (_ FloatingPoint 11 53) ((_ to_fp 11 53) roundNearestTiesToEven (/ 10.0 1.0))) +[GOOD] (define-fun s37 () (_ FloatingPoint 11 53) (fp #b0 #b10000000010 #b0100000000000000000000000000000000000000000000000000)) [GOOD] (define-fun s38 () Bool (fp.eq s13 s37)) [GOOD] (assert s38) [GOOD] (define-fun s39 () Real (/ 11.0 1.0)) diff --git a/SBVTestSuite/GoldFiles/pareto1.gold b/SBVTestSuite/GoldFiles/pareto1.gold --- a/SBVTestSuite/GoldFiles/pareto1.gold +++ b/SBVTestSuite/GoldFiles/pareto1.gold @@ -47,11 +47,11 @@ max_x_plus_y = 6 :: Integer min_y = 4 :: Integer Pareto front #9: Optimal model: - x = 3 :: Integer - y = 4 :: Integer - min_x = 3 :: Integer + x = 4 :: Integer + y = 3 :: Integer + min_x = 4 :: Integer max_x_plus_y = 7 :: Integer - min_y = 4 :: Integer + min_y = 3 :: Integer Pareto front #10: Optimal model: x = 5 :: Integer y = 2 :: Integer @@ -59,35 +59,35 @@ max_x_plus_y = 7 :: Integer min_y = 2 :: Integer Pareto front #11: Optimal model: - x = 4 :: Integer - y = 4 :: Integer - min_x = 4 :: Integer - max_x_plus_y = 8 :: Integer - min_y = 4 :: Integer -Pareto front #12: Optimal model: - x = 4 :: Integer - y = 3 :: Integer - min_x = 4 :: Integer - max_x_plus_y = 7 :: Integer - min_y = 3 :: Integer -Pareto front #13: Optimal model: x = 5 :: Integer y = 3 :: Integer min_x = 5 :: Integer max_x_plus_y = 8 :: Integer min_y = 3 :: Integer -Pareto front #14: Optimal model: - x = 5 :: Integer +Pareto front #12: Optimal model: + x = 3 :: Integer y = 4 :: Integer - min_x = 5 :: Integer - max_x_plus_y = 9 :: Integer + min_x = 3 :: Integer + max_x_plus_y = 7 :: Integer min_y = 4 :: Integer -Pareto front #15: Optimal model: +Pareto front #13: Optimal model: x = 4 :: Integer y = 2 :: Integer min_x = 4 :: Integer max_x_plus_y = 6 :: Integer min_y = 2 :: Integer +Pareto front #14: Optimal model: + x = 4 :: Integer + y = 4 :: Integer + min_x = 4 :: Integer + max_x_plus_y = 8 :: Integer + min_y = 4 :: Integer +Pareto front #15: Optimal model: + x = 5 :: Integer + y = 4 :: Integer + min_x = 5 :: Integer + max_x_plus_y = 9 :: Integer + min_y = 4 :: Integer Pareto front #16: Optimal model: x = 1 :: Integer y = 0 :: Integer @@ -107,65 +107,65 @@ max_x_plus_y = 2 :: Integer min_y = 0 :: Integer Pareto front #19: Optimal model: - x = 3 :: Integer - y = 0 :: Integer - min_x = 3 :: Integer - max_x_plus_y = 3 :: Integer - min_y = 0 :: Integer -Pareto front #20: Optimal model: x = 0 :: Integer y = 1 :: Integer min_x = 0 :: Integer max_x_plus_y = 1 :: Integer min_y = 1 :: Integer -Pareto front #21: Optimal model: +Pareto front #20: Optimal model: x = 2 :: Integer y = 1 :: Integer min_x = 2 :: Integer max_x_plus_y = 3 :: Integer min_y = 1 :: Integer -Pareto front #22: Optimal model: +Pareto front #21: Optimal model: x = 1 :: Integer y = 2 :: Integer min_x = 1 :: Integer max_x_plus_y = 3 :: Integer min_y = 2 :: Integer -Pareto front #23: Optimal model: +Pareto front #22: Optimal model: x = 0 :: Integer y = 2 :: Integer min_x = 0 :: Integer max_x_plus_y = 2 :: Integer min_y = 2 :: Integer -Pareto front #24: Optimal model: +Pareto front #23: Optimal model: x = 0 :: Integer - y = 4 :: Integer + y = 3 :: Integer min_x = 0 :: Integer - max_x_plus_y = 4 :: Integer - min_y = 4 :: Integer -Pareto front #25: Optimal model: + max_x_plus_y = 3 :: Integer + min_y = 3 :: Integer +Pareto front #24: Optimal model: x = 1 :: Integer y = 3 :: Integer min_x = 1 :: Integer max_x_plus_y = 4 :: Integer min_y = 3 :: Integer +Pareto front #25: Optimal model: + x = 0 :: Integer + y = 4 :: Integer + min_x = 0 :: Integer + max_x_plus_y = 4 :: Integer + min_y = 4 :: Integer Pareto front #26: Optimal model: - x = 2 :: Integer - y = 3 :: Integer - min_x = 2 :: Integer - max_x_plus_y = 5 :: Integer - min_y = 3 :: Integer -Pareto front #27: Optimal model: x = 1 :: Integer y = 4 :: Integer min_x = 1 :: Integer max_x_plus_y = 5 :: Integer min_y = 4 :: Integer -Pareto front #28: Optimal model: - x = 0 :: Integer +Pareto front #27: Optimal model: + x = 2 :: Integer y = 3 :: Integer - min_x = 0 :: Integer - max_x_plus_y = 3 :: Integer + min_x = 2 :: Integer + max_x_plus_y = 5 :: Integer min_y = 3 :: Integer +Pareto front #28: Optimal model: + x = 3 :: Integer + y = 0 :: Integer + min_x = 3 :: Integer + max_x_plus_y = 3 :: Integer + min_y = 0 :: Integer Pareto front #29: Optimal model: x = 4 :: Integer y = 0 :: Integer diff --git a/SBVTestSuite/GoldFiles/pareto2.gold b/SBVTestSuite/GoldFiles/pareto2.gold --- a/SBVTestSuite/GoldFiles/pareto2.gold +++ b/SBVTestSuite/GoldFiles/pareto2.gold @@ -1,182 +1,182 @@ Pareto front #1: Optimal model: - x = 0 :: Integer - y = -1 :: Integer - min_x = 0 :: Integer - max_y = -1 :: Integer - max_x_plus_y = -1 :: Integer + x = 0 :: Integer + y = 1 :: Integer + min_x = 0 :: Integer + max_y = 1 :: Integer + max_x_plus_y = 1 :: Integer Pareto front #2: Optimal model: - x = 0 :: Integer - y = -3 :: Integer - min_x = 0 :: Integer - max_y = -3 :: Integer - max_x_plus_y = -3 :: Integer + x = 0 :: Integer + y = 2 :: Integer + min_x = 0 :: Integer + max_y = 2 :: Integer + max_x_plus_y = 2 :: Integer Pareto front #3: Optimal model: - x = 0 :: Integer - y = -5 :: Integer - min_x = 0 :: Integer - max_y = -5 :: Integer - max_x_plus_y = -5 :: Integer + x = 0 :: Integer + y = 3 :: Integer + min_x = 0 :: Integer + max_y = 3 :: Integer + max_x_plus_y = 3 :: Integer Pareto front #4: Optimal model: - x = 0 :: Integer - y = -7 :: Integer - min_x = 0 :: Integer - max_y = -7 :: Integer - max_x_plus_y = -7 :: Integer + x = 0 :: Integer + y = 5 :: Integer + min_x = 0 :: Integer + max_y = 5 :: Integer + max_x_plus_y = 5 :: Integer Pareto front #5: Optimal model: - x = 0 :: Integer - y = -9 :: Integer - min_x = 0 :: Integer - max_y = -9 :: Integer - max_x_plus_y = -9 :: Integer + x = 0 :: Integer + y = 6 :: Integer + min_x = 0 :: Integer + max_y = 6 :: Integer + max_x_plus_y = 6 :: Integer Pareto front #6: Optimal model: - x = 0 :: Integer - y = -10 :: Integer - min_x = 0 :: Integer - max_y = -10 :: Integer - max_x_plus_y = -10 :: Integer + x = 0 :: Integer + y = 7 :: Integer + min_x = 0 :: Integer + max_y = 7 :: Integer + max_x_plus_y = 7 :: Integer Pareto front #7: Optimal model: - x = 0 :: Integer - y = -11 :: Integer - min_x = 0 :: Integer - max_y = -11 :: Integer - max_x_plus_y = -11 :: Integer + x = 0 :: Integer + y = 9 :: Integer + min_x = 0 :: Integer + max_y = 9 :: Integer + max_x_plus_y = 9 :: Integer Pareto front #8: Optimal model: - x = 0 :: Integer - y = -13 :: Integer - min_x = 0 :: Integer - max_y = -13 :: Integer - max_x_plus_y = -13 :: Integer + x = 0 :: Integer + y = 8 :: Integer + min_x = 0 :: Integer + max_y = 8 :: Integer + max_x_plus_y = 8 :: Integer Pareto front #9: Optimal model: - x = 0 :: Integer - y = -15 :: Integer - min_x = 0 :: Integer - max_y = -15 :: Integer - max_x_plus_y = -15 :: Integer + x = 0 :: Integer + y = 11 :: Integer + min_x = 0 :: Integer + max_y = 11 :: Integer + max_x_plus_y = 11 :: Integer Pareto front #10: Optimal model: - x = 0 :: Integer - y = -16 :: Integer - min_x = 0 :: Integer - max_y = -16 :: Integer - max_x_plus_y = -16 :: Integer + x = 0 :: Integer + y = 13 :: Integer + min_x = 0 :: Integer + max_y = 13 :: Integer + max_x_plus_y = 13 :: Integer Pareto front #11: Optimal model: - x = 0 :: Integer - y = -18 :: Integer - min_x = 0 :: Integer - max_y = -18 :: Integer - max_x_plus_y = -18 :: Integer + x = 0 :: Integer + y = 14 :: Integer + min_x = 0 :: Integer + max_y = 14 :: Integer + max_x_plus_y = 14 :: Integer Pareto front #12: Optimal model: - x = 0 :: Integer - y = -20 :: Integer - min_x = 0 :: Integer - max_y = -20 :: Integer - max_x_plus_y = -20 :: Integer + x = 0 :: Integer + y = 15 :: Integer + min_x = 0 :: Integer + max_y = 15 :: Integer + max_x_plus_y = 15 :: Integer Pareto front #13: Optimal model: - x = 0 :: Integer - y = -22 :: Integer - min_x = 0 :: Integer - max_y = -22 :: Integer - max_x_plus_y = -22 :: Integer + x = 0 :: Integer + y = 17 :: Integer + min_x = 0 :: Integer + max_y = 17 :: Integer + max_x_plus_y = 17 :: Integer Pareto front #14: Optimal model: - x = 0 :: Integer - y = -23 :: Integer - min_x = 0 :: Integer - max_y = -23 :: Integer - max_x_plus_y = -23 :: Integer + x = 0 :: Integer + y = 19 :: Integer + min_x = 0 :: Integer + max_y = 19 :: Integer + max_x_plus_y = 19 :: Integer Pareto front #15: Optimal model: - x = 0 :: Integer - y = -24 :: Integer - min_x = 0 :: Integer - max_y = -24 :: Integer - max_x_plus_y = -24 :: Integer + x = 0 :: Integer + y = 21 :: Integer + min_x = 0 :: Integer + max_y = 21 :: Integer + max_x_plus_y = 21 :: Integer Pareto front #16: Optimal model: - x = 0 :: Integer - y = -26 :: Integer - min_x = 0 :: Integer - max_y = -26 :: Integer - max_x_plus_y = -26 :: Integer + x = 0 :: Integer + y = 22 :: Integer + min_x = 0 :: Integer + max_y = 22 :: Integer + max_x_plus_y = 22 :: Integer Pareto front #17: Optimal model: - x = 0 :: Integer - y = -28 :: Integer - min_x = 0 :: Integer - max_y = -28 :: Integer - max_x_plus_y = -28 :: Integer + x = 0 :: Integer + y = 23 :: Integer + min_x = 0 :: Integer + max_y = 23 :: Integer + max_x_plus_y = 23 :: Integer Pareto front #18: Optimal model: - x = 0 :: Integer - y = -29 :: Integer - min_x = 0 :: Integer - max_y = -29 :: Integer - max_x_plus_y = -29 :: Integer + x = 0 :: Integer + y = 25 :: Integer + min_x = 0 :: Integer + max_y = 25 :: Integer + max_x_plus_y = 25 :: Integer Pareto front #19: Optimal model: - x = 0 :: Integer - y = -31 :: Integer - min_x = 0 :: Integer - max_y = -31 :: Integer - max_x_plus_y = -31 :: Integer + x = 0 :: Integer + y = 26 :: Integer + min_x = 0 :: Integer + max_y = 26 :: Integer + max_x_plus_y = 26 :: Integer Pareto front #20: Optimal model: - x = 0 :: Integer - y = -32 :: Integer - min_x = 0 :: Integer - max_y = -32 :: Integer - max_x_plus_y = -32 :: Integer + x = 0 :: Integer + y = 28 :: Integer + min_x = 0 :: Integer + max_y = 28 :: Integer + max_x_plus_y = 28 :: Integer Pareto front #21: Optimal model: - x = 0 :: Integer - y = -34 :: Integer - min_x = 0 :: Integer - max_y = -34 :: Integer - max_x_plus_y = -34 :: Integer + x = 0 :: Integer + y = 30 :: Integer + min_x = 0 :: Integer + max_y = 30 :: Integer + max_x_plus_y = 30 :: Integer Pareto front #22: Optimal model: - x = 0 :: Integer - y = -35 :: Integer - min_x = 0 :: Integer - max_y = -35 :: Integer - max_x_plus_y = -35 :: Integer + x = 0 :: Integer + y = 32 :: Integer + min_x = 0 :: Integer + max_y = 32 :: Integer + max_x_plus_y = 32 :: Integer Pareto front #23: Optimal model: - x = 0 :: Integer - y = -37 :: Integer - min_x = 0 :: Integer - max_y = -37 :: Integer - max_x_plus_y = -37 :: Integer + x = 0 :: Integer + y = 34 :: Integer + min_x = 0 :: Integer + max_y = 34 :: Integer + max_x_plus_y = 34 :: Integer Pareto front #24: Optimal model: - x = 0 :: Integer - y = -38 :: Integer - min_x = 0 :: Integer - max_y = -38 :: Integer - max_x_plus_y = -38 :: Integer + x = 0 :: Integer + y = 36 :: Integer + min_x = 0 :: Integer + max_y = 36 :: Integer + max_x_plus_y = 36 :: Integer Pareto front #25: Optimal model: - x = 0 :: Integer - y = -40 :: Integer - min_x = 0 :: Integer - max_y = -40 :: Integer - max_x_plus_y = -40 :: Integer + x = 0 :: Integer + y = 37 :: Integer + min_x = 0 :: Integer + max_y = 37 :: Integer + max_x_plus_y = 37 :: Integer Pareto front #26: Optimal model: - x = 0 :: Integer - y = -41 :: Integer - min_x = 0 :: Integer - max_y = -41 :: Integer - max_x_plus_y = -41 :: Integer + x = 0 :: Integer + y = 39 :: Integer + min_x = 0 :: Integer + max_y = 39 :: Integer + max_x_plus_y = 39 :: Integer Pareto front #27: Optimal model: - x = 0 :: Integer - y = -43 :: Integer - min_x = 0 :: Integer - max_y = -43 :: Integer - max_x_plus_y = -43 :: Integer + x = 0 :: Integer + y = 40 :: Integer + min_x = 0 :: Integer + max_y = 40 :: Integer + max_x_plus_y = 40 :: Integer Pareto front #28: Optimal model: - x = 0 :: Integer - y = -44 :: Integer - min_x = 0 :: Integer - max_y = -44 :: Integer - max_x_plus_y = -44 :: Integer + x = 0 :: Integer + y = 41 :: Integer + min_x = 0 :: Integer + max_y = 41 :: Integer + max_x_plus_y = 41 :: Integer Pareto front #29: Optimal model: - x = 0 :: Integer - y = -45 :: Integer - min_x = 0 :: Integer - max_y = -45 :: Integer - max_x_plus_y = -45 :: Integer + x = 0 :: Integer + y = 43 :: Integer + min_x = 0 :: Integer + max_y = 43 :: Integer + max_x_plus_y = 43 :: Integer Pareto front #30: Optimal model: - x = 0 :: Integer - y = -47 :: Integer - min_x = 0 :: Integer - max_y = -47 :: Integer - max_x_plus_y = -47 :: Integer + x = 0 :: Integer + y = 44 :: Integer + min_x = 0 :: Integer + max_y = 44 :: Integer + max_x_plus_y = 44 :: Integer *** Note: Pareto-front extraction was terminated as requested by the user. *** There might be many other results! diff --git a/SBVTestSuite/GoldFiles/query_cvc5.gold b/SBVTestSuite/GoldFiles/query_cvc5.gold --- a/SBVTestSuite/GoldFiles/query_cvc5.gold +++ b/SBVTestSuite/GoldFiles/query_cvc5.gold @@ -4,7 +4,7 @@ [GOOD] (set-option :global-declarations true) [GOOD] (set-option :diagnostic-output-channel "stdout") [GOOD] (set-option :produce-models true) -[GOOD] (set-logic ALL) ; external query, using all logics. +[GOOD] (set-logic HO_ALL) ; external query, using all logics. [GOOD] ; --- tuples --- [GOOD] ; --- sums --- [GOOD] ; --- literal constants --- diff --git a/SBVTestSuite/GoldFiles/query_uisatex1.gold b/SBVTestSuite/GoldFiles/query_uisatex1.gold --- a/SBVTestSuite/GoldFiles/query_uisatex1.gold +++ b/SBVTestSuite/GoldFiles/query_uisatex1.gold @@ -22,26 +22,26 @@ [GOOD] (define-fun s21 () Int 5) [GOOD] (define-fun s23 () Int 7) [GOOD] (define-fun s25 () Int 6) -[GOOD] (define-fun s29 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 4508877.0 524288.0))) -[GOOD] (define-fun s32 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 5033165.0 524288.0))) +[GOOD] (define-fun s29 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00010011001100110011010)) +[GOOD] (define-fun s32 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00110011001100110011010)) [GOOD] (define-fun s33 () Int 121) [GOOD] (define-fun s38 () Int 8) [GOOD] (define-fun s40 () (_ FloatingPoint 8 24) (_ +oo 8 24)) [GOOD] (define-fun s42 () String (_ char #x63)) [GOOD] (define-fun s43 () String "hey") -[GOOD] (define-fun s45 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 78.0 1.0))) +[GOOD] (define-fun s45 () (_ FloatingPoint 8 24) (fp #b0 #b10000101 #b00111000000000000000000)) [GOOD] (define-fun s47 () String "tey") -[GOOD] (define-fun s49 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 92.0 1.0))) +[GOOD] (define-fun s49 () (_ FloatingPoint 8 24) (fp #b0 #b10000101 #b01110000000000000000000)) [GOOD] (define-fun s51 () String (_ char #x72)) [GOOD] (define-fun s52 () String "foo") -[GOOD] (define-fun s54 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 7.0 2.0))) +[GOOD] (define-fun s54 () (_ FloatingPoint 8 24) (fp #b0 #b10000000 #b11000000000000000000000)) [GOOD] (define-fun s56 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3))) -[GOOD] (define-fun s57 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 3.0 1.0))))) +[GOOD] (define-fun s57 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (fp #b0 #b10000000 #b10000000000000000000000)))) [GOOD] (define-fun s60 () (Seq Int) (seq.++ (seq.unit 9) (seq.unit 5))) -[GOOD] (define-fun s61 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 9.0 1.0))))) +[GOOD] (define-fun s61 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (fp #b0 #b10000010 #b00100000000000000000000)))) [GOOD] (define-fun s63 () Int 21) [GOOD] (define-fun s65 () (Seq Int) (seq.unit 5)) -[GOOD] (define-fun s66 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit (_ +zero 8 24)))) +[GOOD] (define-fun s66 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (_ +zero 8 24)))) [GOOD] (define-fun s68 () Int 210) [GOOD] ; --- top level inputs --- [GOOD] (declare-fun s0 () Int) diff --git a/SBVTestSuite/GoldFiles/query_uisatex2.gold b/SBVTestSuite/GoldFiles/query_uisatex2.gold --- a/SBVTestSuite/GoldFiles/query_uisatex2.gold +++ b/SBVTestSuite/GoldFiles/query_uisatex2.gold @@ -22,26 +22,26 @@ [GOOD] (define-fun s21 () Int 5) [GOOD] (define-fun s23 () Int 7) [GOOD] (define-fun s25 () Int 6) -[GOOD] (define-fun s29 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 4508877.0 524288.0))) -[GOOD] (define-fun s32 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 5033165.0 524288.0))) +[GOOD] (define-fun s29 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00010011001100110011010)) +[GOOD] (define-fun s32 () (_ FloatingPoint 8 24) (fp #b0 #b10000010 #b00110011001100110011010)) [GOOD] (define-fun s33 () Int 121) [GOOD] (define-fun s38 () Int 8) [GOOD] (define-fun s40 () (_ FloatingPoint 8 24) (_ +oo 8 24)) [GOOD] (define-fun s42 () String (_ char #x63)) [GOOD] (define-fun s43 () String "hey") -[GOOD] (define-fun s45 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 78.0 1.0))) +[GOOD] (define-fun s45 () (_ FloatingPoint 8 24) (fp #b0 #b10000101 #b00111000000000000000000)) [GOOD] (define-fun s47 () String "tey") -[GOOD] (define-fun s49 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 92.0 1.0))) +[GOOD] (define-fun s49 () (_ FloatingPoint 8 24) (fp #b0 #b10000101 #b01110000000000000000000)) [GOOD] (define-fun s51 () String (_ char #x72)) [GOOD] (define-fun s52 () String "foo") -[GOOD] (define-fun s54 () (_ FloatingPoint 8 24) ((_ to_fp 8 24) roundNearestTiesToEven (/ 7.0 2.0))) +[GOOD] (define-fun s54 () (_ FloatingPoint 8 24) (fp #b0 #b10000000 #b11000000000000000000000)) [GOOD] (define-fun s56 () (Seq Int) (seq.++ (seq.unit 1) (seq.unit 2) (seq.unit 3))) -[GOOD] (define-fun s57 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 3.0 1.0))))) +[GOOD] (define-fun s57 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (fp #b0 #b10000000 #b10000000000000000000000)))) [GOOD] (define-fun s60 () (Seq Int) (seq.++ (seq.unit 9) (seq.unit 5))) -[GOOD] (define-fun s61 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 9.0 1.0))))) +[GOOD] (define-fun s61 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (fp #b0 #b10000010 #b00100000000000000000000)))) [GOOD] (define-fun s63 () Int 21) [GOOD] (define-fun s65 () (Seq Int) (seq.unit 5)) -[GOOD] (define-fun s66 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit ((_ to_fp 8 24) roundNearestTiesToEven (/ 8598323.0 1048576.0))) (seq.unit (_ +zero 8 24)))) +[GOOD] (define-fun s66 () (Seq (_ FloatingPoint 8 24)) (seq.++ (seq.unit (fp #b0 #b10000010 #b00000110011001100110011)) (seq.unit (_ +zero 8 24)))) [GOOD] (define-fun s68 () Int 210) [GOOD] ; --- top level inputs --- [GOOD] (declare-fun s0 () Int) diff --git a/SBVTestSuite/GoldFiles/recursive20_mutualTP.gold b/SBVTestSuite/GoldFiles/recursive20_mutualTP.gold --- a/SBVTestSuite/GoldFiles/recursive20_mutualTP.gold +++ b/SBVTestSuite/GoldFiles/recursive20_mutualTP.gold @@ -215,7 +215,7 @@ [GOOD] (assert s7) [SEND] (check-sat) [RECV] unsat - Q.E.D. + Q.E.D. *** Solver : Z3 *** Exit code: ExitSuccess Functions proven terminating: mf_tp, mg_tp diff --git a/SBVTestSuite/GoldFiles/recursive28_noTermCheck.gold b/SBVTestSuite/GoldFiles/recursive28_noTermCheck.gold --- a/SBVTestSuite/GoldFiles/recursive28_noTermCheck.gold +++ b/SBVTestSuite/GoldFiles/recursive28_noTermCheck.gold @@ -47,7 +47,7 @@ [GOOD] (assert s7) [SEND] (check-sat) [RECV] unsat - Q.E.D. [Modulo: ntc28 termination] + Q.E.D. [Modulo: ntc28 termination] *** Solver : Z3 *** Exit code: ExitSuccess [Modulo: ntc28 termination] ntc_at_5 :: Ɐn ∷ Integer → Bool diff --git a/SBVTestSuite/GoldFiles/recursive6_uselessContract.gold b/SBVTestSuite/GoldFiles/recursive6_uselessContract.gold --- a/SBVTestSuite/GoldFiles/recursive6_uselessContract.gold +++ b/SBVTestSuite/GoldFiles/recursive6_uselessContract.gold @@ -112,21 +112,21 @@ [SEND] (check-sat) [RECV] sat [SEND] (get-value (s28)) -[RECV] ((s28 101)) +[RECV] ((s28 12)) [SEND] (get-value (s31)) -[RECV] ((s31 90)) +[RECV] ((s31 1)) [SEND] (get-value (s34)) -[RECV] ((s34 101)) +[RECV] ((s34 12)) [SEND] (get-value (s0)) -[RECV] ((s0 0)) +[RECV] ((s0 89)) [SEND] (get-value (s7)) -[RECV] ((s7 0)) +[RECV] ((s7 89)) [SEND] (get-value (s8)) [RECV] ((s8 0)) [SEND] (get-value (s13)) [RECV] ((s13 0)) [SEND] (get-value (s14)) -[RECV] ((s14 0)) +[RECV] ((s14 89)) [SEND] (get-value (s20)) [RECV] ((s20 0)) [SEND] (get-value (s21)) @@ -141,10 +141,10 @@ *** Function: mc91triv :: SBV Integer -> SBV Integer *** *** Falsifiable. Counter-example: -*** arg = 0 :: Integer -*** before = 101 :: Integer -*** then[1] = 90 :: Integer -*** then[2] = 101 :: Integer +*** arg = 89 :: Integer +*** before = 12 :: Integer +*** then[1] = 1 :: Integer +*** then[2] = 12 :: Integer *** *** The measure must strictly decrease at every recursive call, *** and the contract must hold for the function's output. diff --git a/SBVTestSuite/GoldFiles/tpCache_alias.gold b/SBVTestSuite/GoldFiles/tpCache_alias.gold --- a/SBVTestSuite/GoldFiles/tpCache_alias.gold +++ b/SBVTestSuite/GoldFiles/tpCache_alias.gold @@ -1,3 +1,3 @@ -Lemma: nameA Q.E.D. -Lemma: nameB Q.E.D. -Cached: nameC Q.E.D. (a.k.a. nameA, nameB) +Lemma: nameA Q.E.D. +Lemma: nameB Q.E.D. +Lemma: nameC Q.E.D. [Cached] (a.k.a. nameA, nameB) diff --git a/SBVTestSuite/GoldFiles/tpCache_barFail.gold b/SBVTestSuite/GoldFiles/tpCache_barFail.gold new file mode 100644 --- /dev/null +++ b/SBVTestSuite/GoldFiles/tpCache_barFail.gold @@ -0,0 +1,4 @@ +Lemma: foo +*** Failed to prove foo. +Falsifiable. Counter-example: + x = 0 :: Integer diff --git a/SBVTestSuite/GoldFiles/tpCache_calcCollapse.gold b/SBVTestSuite/GoldFiles/tpCache_calcCollapse.gold --- a/SBVTestSuite/GoldFiles/tpCache_calcCollapse.gold +++ b/SBVTestSuite/GoldFiles/tpCache_calcCollapse.gold @@ -1,4 +1,4 @@ Lemma: addZero - Step: 1 Q.E.D. - Result: Q.E.D. -Cached: addZero Q.E.D. + Step: 1 Q.E.D. + Result: Q.E.D. +Lemma: addZero Q.E.D. [Cached] diff --git a/SBVTestSuite/GoldFiles/tpCache_fooFail.gold b/SBVTestSuite/GoldFiles/tpCache_fooFail.gold new file mode 100644 --- /dev/null +++ b/SBVTestSuite/GoldFiles/tpCache_fooFail.gold @@ -0,0 +1,4 @@ +Lemma: foo +*** Failed to prove foo. +Falsifiable. Counter-example: + x = 0 :: Integer diff --git a/SBVTestSuite/GoldFiles/tpCache_hit.gold b/SBVTestSuite/GoldFiles/tpCache_hit.gold --- a/SBVTestSuite/GoldFiles/tpCache_hit.gold +++ b/SBVTestSuite/GoldFiles/tpCache_hit.gold @@ -1,2 +1,2 @@ -Lemma: fact Q.E.D. -Cached: fact Q.E.D. +Lemma: fact Q.E.D. +Lemma: fact Q.E.D. [Cached] diff --git a/SBVTestSuite/GoldFiles/tpCache_miss.gold b/SBVTestSuite/GoldFiles/tpCache_miss.gold --- a/SBVTestSuite/GoldFiles/tpCache_miss.gold +++ b/SBVTestSuite/GoldFiles/tpCache_miss.gold @@ -1,1 +1,1 @@ -Lemma: fact Q.E.D. +Lemma: fact Q.E.D. diff --git a/SBVTestSuite/GoldFiles/tpCache_nested.gold b/SBVTestSuite/GoldFiles/tpCache_nested.gold --- a/SBVTestSuite/GoldFiles/tpCache_nested.gold +++ b/SBVTestSuite/GoldFiles/tpCache_nested.gold @@ -1,3 +1,3 @@ -Lemma: inner Q.E.D. -Lemma: outer Q.E.D. -Cached: outer Q.E.D. (a.k.a. inner) +Lemma: inner Q.E.D. +Lemma: outer Q.E.D. +Lemma: outer Q.E.D. [Cached] (a.k.a. inner) diff --git a/SBVTestSuite/GoldFiles/tpCache_recallFail.gold b/SBVTestSuite/GoldFiles/tpCache_recallFail.gold new file mode 100644 --- /dev/null +++ b/SBVTestSuite/GoldFiles/tpCache_recallFail.gold @@ -0,0 +1,4 @@ +Lemma: bad +*** Failed to prove bad. +Falsifiable. Counter-example: + x = 0 :: Integer diff --git a/SBVTestSuite/GoldFiles/tpCache_statsHit.gold b/SBVTestSuite/GoldFiles/tpCache_statsHit.gold --- a/SBVTestSuite/GoldFiles/tpCache_statsHit.gold +++ b/SBVTestSuite/GoldFiles/tpCache_statsHit.gold @@ -1,4 +1,4 @@ Lemma: addZero - Step: 1 Q.E.D. - Result: Q.E.D. -Cached: addZero Q.E.D. + Step: 1 Q.E.D. + Result: Q.E.D. +Lemma: addZero Q.E.D. [Cached] diff --git a/SBVTestSuite/GoldFiles/tpCache_statsMiss.gold b/SBVTestSuite/GoldFiles/tpCache_statsMiss.gold --- a/SBVTestSuite/GoldFiles/tpCache_statsMiss.gold +++ b/SBVTestSuite/GoldFiles/tpCache_statsMiss.gold @@ -1,3 +1,3 @@ Lemma: addZero - Step: 1 Q.E.D. - Result: Q.E.D. + Step: 1 Q.E.D. + Result: Q.E.D. diff --git a/SBVTestSuite/GoldFiles/tpCache_statsNested.gold b/SBVTestSuite/GoldFiles/tpCache_statsNested.gold --- a/SBVTestSuite/GoldFiles/tpCache_statsNested.gold +++ b/SBVTestSuite/GoldFiles/tpCache_statsNested.gold @@ -1,4 +1,4 @@ -Lemma: inner Q.E.D. -Lemma: outer Q.E.D. -Cached: inner Q.E.D. (a.k.a. outer) -Cached: outer Q.E.D. (a.k.a. inner) +Lemma: inner Q.E.D. +Lemma: outer Q.E.D. +Lemma: inner Q.E.D. [Cached] (a.k.a. outer) +Lemma: outer Q.E.D. [Cached] (a.k.a. inner) diff --git a/SBVTestSuite/TestSuite/Arrays/InitVals.hs b/SBVTestSuite/TestSuite/Arrays/InitVals.hs --- a/SBVTestSuite/TestSuite/Arrays/InitVals.hs +++ b/SBVTestSuite/TestSuite/Arrays/InitVals.hs @@ -10,7 +10,7 @@ ----------------------------------------------------------------------------- {-# LANGUAGE DataKinds #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-} diff --git a/SBVTestSuite/TestSuite/Arrays/Memory.hs b/SBVTestSuite/TestSuite/Arrays/Memory.hs --- a/SBVTestSuite/TestSuite/Arrays/Memory.hs +++ b/SBVTestSuite/TestSuite/Arrays/Memory.hs @@ -9,7 +9,7 @@ -- Test suite for Examples.Arrays.Memory ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wall -Werror #-} diff --git a/SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs b/SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs --- a/SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs +++ b/SBVTestSuite/TestSuite/Basics/ArithNoSolver.hs @@ -10,15 +10,10 @@ -- the constant folding based arithmetic implementation in SBV ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} -#if MIN_VERSION_base(4,19,0) {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-} -#else -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} -#endif module TestSuite.Basics.ArithNoSolver(tests) where diff --git a/SBVTestSuite/TestSuite/Basics/ArithNoSolver2.hs b/SBVTestSuite/TestSuite/Basics/ArithNoSolver2.hs --- a/SBVTestSuite/TestSuite/Basics/ArithNoSolver2.hs +++ b/SBVTestSuite/TestSuite/Basics/ArithNoSolver2.hs @@ -10,20 +10,15 @@ -- the constant folding based arithmetic implementation in SBV ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE QuasiQuotes #-} -#if MIN_VERSION_base(4,19,0) {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-} -#else -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} -#endif module TestSuite.Basics.ArithNoSolver2(tests) where diff --git a/SBVTestSuite/TestSuite/Basics/ArithSolver.hs b/SBVTestSuite/TestSuite/Basics/ArithSolver.hs --- a/SBVTestSuite/TestSuite/Basics/ArithSolver.hs +++ b/SBVTestSuite/TestSuite/Basics/ArithSolver.hs @@ -11,21 +11,16 @@ -- constant folding. ----------------------------------------------------------------------------- -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} -#if MIN_VERSION_base(4,19,0) {-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns -Wno-x-partial #-} -#else -{-# OPTIONS_GHC -Wall -Werror -Wno-incomplete-uni-patterns #-} -#endif module TestSuite.Basics.ArithSolver(tests) where diff --git a/SBVTestSuite/TestSuite/Basics/BasicTests.hs b/SBVTestSuite/TestSuite/Basics/BasicTests.hs --- a/SBVTestSuite/TestSuite/Basics/BasicTests.hs +++ b/SBVTestSuite/TestSuite/Basics/BasicTests.hs @@ -9,7 +9,7 @@ -- Test suite for Examples.Basics.BasicTests ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-} diff --git a/SBVTestSuite/TestSuite/Basics/TPCaching.hs b/SBVTestSuite/TestSuite/Basics/TPCaching.hs --- a/SBVTestSuite/TestSuite/Basics/TPCaching.hs +++ b/SBVTestSuite/TestSuite/Basics/TPCaching.hs @@ -19,23 +19,25 @@ import Utils.SBVTestFramework -import Data.SBV.TP (runTPWith, lemma, calc, recall, tpStats, (|-), (=:), qed) +import Data.SBV.TP (TP, Proof, runTPWith, lemma, calc, recall, tpStats, (|-), (=:), qed) import Control.Monad (void) +import Control.Exception (try, SomeException) import Data.Char (isSpace) import Data.List (isPrefixOf, dropWhileEnd) import Control.DeepSeq (($!!)) --- | Strip timing info [0.05s] from the end of output lines. +-- | Strip timing info like @[0.05s]@ from the end of output lines. +-- Only matches brackets whose content looks like a time value (digits, dots, and 's'). +-- Handles multiple consecutive timings like @[0.001s][0.002s]@. stripTiming :: String -> String -stripTiming s - | (_, rest@('[':_)) <- break (== '[') (dropWhileEnd isSpace s) - , last rest == ']' - = dropWhileEnd isSpace $ take (length s - length rest) s - | True - = s +stripTiming s = reverse $ go $ reverse $ dropWhileEnd isSpace s + where go (']':rest) | (inner, '[':before) <- break (== '[') rest + , all (`elem` ("0123456789.s" :: String)) inner + = go $ dropWhile isSpace before + go xs = xs -- | Filter out the statistics summary line from verbose output. isStatsLine :: String -> Bool @@ -57,7 +59,7 @@ recall (lemma "fact" sTrue []) -- Normal mode: direct proof then recall (cache hit). - -- The direct proof shows "Lemma:", the recall shows "Cached:". + -- The direct proof shows "Lemma:", the recall shows "Lemma: ... [Cached]". , goldenCapturedIO "tpCache_hit" $ \rf -> do let cfg = z3 { redirectVerbose = Just rf } void $ runTPWith cfg $ do @@ -65,7 +67,7 @@ recall (lemma "fact" sTrue []) -- Normal mode: same proposition proved under two names, then recalled (aliases). - -- The recall shows "Cached:" with "(a.k.a. ...)" listing the other name. + -- The recall shows "Lemma: ... [Cached]" with "(a.k.a. ...)" listing the other name. , goldenCapturedIO "tpCache_alias" $ \rf -> do let cfg = z3 { redirectVerbose = Just rf } void $ runTPWith cfg $ do @@ -110,7 +112,7 @@ writeFile rf $!! cleanStatsOutput contents -- Stats mode: direct proof then recall (cache hit). - -- Direct proof shows full steps; recall shows "Cached:" one-liner. + -- Direct proof shows full steps; recall shows "Lemma: ... [Cached]" one-liner. , goldenCapturedIO "tpCache_statsHit" $ \rf -> do let cfg = (tpStats z3) { redirectVerbose = Just rf } void $ runTPWith cfg $ do @@ -125,7 +127,7 @@ writeFile rf $!! cleanStatsOutput contents -- Stats mode: nested recall showing inner cache dynamics. - -- First recall misses (shows full inner proofs). Second recall hits (shows "Cached:"). + -- First recall misses (shows full inner proofs). Second recall hits (shows "Lemma: ... [Cached]"). , goldenCapturedIO "tpCache_statsNested" $ \rf -> do let cfg = (tpStats z3) { redirectVerbose = Just rf } void $ runTPWith cfg $ do @@ -135,4 +137,42 @@ recall (lemma "outer" sTrue []) contents <- readFile rf writeFile rf $!! cleanStatsOutput contents + + -- Recall of a failing proof: the lemma is false (x > x), so the proof should fail. + , goldenCapturedIO "tpCache_recallFail" $ \rf -> do + let cfg = z3 { redirectVerbose = Just rf } + res <- try $ void $ runTPWith cfg $ + recall bad + case res of + Left (_ :: SomeException) -> pure () + Right _ -> appendFile rf "Unexpected success\n" + + -- Direct proof of a false lemma. + , goldenCapturedIO "tpCache_fooFail" $ \rf -> do + let cfg = z3 { redirectVerbose = Just rf } + res <- try $ void $ runTPWith cfg foo + case res of + Left (_ :: SomeException) -> pure () + Right _ -> appendFile rf "Unexpected success\n" + + -- Recall of a failing lemma inside a larger proof. + , goldenCapturedIO "tpCache_barFail" $ \rf -> do + let cfg = z3 { redirectVerbose = Just rf } + res <- try $ void $ runTPWith cfg bar + case res of + Left (_ :: SomeException) -> pure () + Right _ -> appendFile rf "Unexpected success\n" ] + +-- | A trivially false lemma, used to test recall of a failing proof. +bad :: TP (Proof (Forall "x" Integer -> SBool)) +bad = lemma "bad" (\(Forall @"x" (x :: SInteger)) -> x .> x) [] + +-- | A false lemma: x == x+1. +foo :: TP (Proof (Forall "x" Integer -> SBool)) +foo = lemma "foo" (\(Forall @"x" (x :: SInteger)) -> x .== x + 1) [] + +-- | Recalls foo (which fails), then tries to prove another false lemma. +bar :: TP (Proof (Forall "x" Integer -> SBool)) +bar = do _f <- recall foo + lemma "bar" (\(Forall @"x" (x :: SInteger)) -> x .== x + 2) [] diff --git a/SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.stderr b/SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.stderr --- a/SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.stderr +++ b/SBVTestSuite/TestSuite/CompileTests/PCase/PCase17.stderr @@ -15,8 +15,8 @@ (isLet e ==> (e .== e =: qed))] PCase17.hs:18:14: error: [GHC-83865] " Couldn't match expected type: Proof SBool - with actual type: sbv-14.0:Data.SBV.TP.TP.TPProofGen - (SBV Bool) [sbv-14.0:Data.SBV.TP.TP.Helper] () + with actual type: sbv-14.1:Data.SBV.TP.TP.TPProofGen + (SBV Bool) [sbv-14.1:Data.SBV.TP.TP.Helper] () " In the expression: cases [(isZero e ==> (e .== e =: qed)), (isNum e ==> (e .== e =: qed)), diff --git a/SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.stderr b/SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.stderr --- a/SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.stderr +++ b/SBVTestSuite/TestSuite/CompileTests/PCase/PCase38.stderr @@ -15,8 +15,8 @@ (isLet e ==> undefined)] PCase38.hs:12:14: error: [GHC-83865] " Couldn't match expected type: Proof SBool - with actual type: sbv-14.0:Data.SBV.TP.TP.TPProofGen - a0 [sbv-14.0:Data.SBV.TP.TP.Helper] () + with actual type: sbv-14.1:Data.SBV.TP.TP.TPProofGen + a0 [sbv-14.1:Data.SBV.TP.TP.Helper] () " In the expression: cases [(isZero e ==> undefined), (isNum e ==> undefined), diff --git a/SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.hs b/SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.hs new file mode 100644 --- /dev/null +++ b/SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeAbstractions #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wall -Werror -Wno-name-shadowing -ddump-splices #-} + +-- Positive: Scoping regression test for pCase. Pattern var 'k' from 'Num k' is +-- used in one branch of a nested case on SBool, while a sibling branch shadows +-- 'k' with a let binding. Old scope-unaware freeVars would drop the accessor +-- binding for 'k', causing a compilation error. See also SCase107 for the sCase +-- counterpart. +module T where + +import Expr +import Data.SBV +import Data.SBV.TP + +t :: TP (Proof (Forall "e" Expr -> Forall "b" Bool -> SBool)) +t = calc "t" (\(Forall @"e" (e :: SExpr)) (Forall @"b" (_ :: SBool)) -> e .== e) $ \e b -> [] + |- [pCase| e of + Zero -> e .== e =: qed + Num k -> case b of + True -> let k = (0 :: SInteger) in k .== k =: e .== e =: qed + False -> k .>= 0 .|| e .== e =: sTrue =: qed + Var _ -> e .== e =: qed + Add _ _ -> e .== e =: qed + Let _ _ _ -> e .== e =: qed + |] diff --git a/SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.stderr b/SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.stderr new file mode 100644 --- /dev/null +++ b/SBVTestSuite/TestSuite/CompileTests/PCase/PCase77.stderr @@ -0,0 +1,24 @@ +PCase77.hs:(22,15)-(30,9): Splicing expression + ghc-internal:GHC.Internal.TH.Quote.quoteExp + pCase + " e of\n\ + \ Zero -> e .== e =: qed\n\ + \ Num k -> case b of\n\ + \ True -> let k = (0 :: SInteger) in k .== k =: e .== e =: qed\n\ + \ False -> k .>= 0 .|| e .== e =: sTrue =: qed\n\ + \ Var _ -> e .== e =: qed\n\ + \ Add _ _ -> e .== e =: qed\n\ + \ Let _ _ _ -> e .== e =: qed\n\ + \ " + ======> + cases + [(isZero e ==> (e .== e =: qed)), + (isNum e + ==> + (let k = getNum_1 e + in + cases + [(b ==> (let k = (0 :: SInteger) in k .== k =: e .== e =: qed)), + (sNot b ==> (k .>= 0 .|| e .== e =: sTrue =: qed))])), + (isVar e ==> (e .== e =: qed)), (isAdd e ==> (e .== e =: qed)), + (isLet e ==> (e .== e =: qed))] diff --git a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.stderr b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.stderr --- a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.stderr +++ b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase101.stderr @@ -28,4 +28,4 @@ ((\ _ -> 1) (Data.SBV.Maybe.getJust_1 m)) (ite (Data.SBV.Maybe.isNothing m) 0 - (symWithKind "unmatched_sCase_Maybe_6989586621679034927"))) + (symWithKind "unmatched_sCase_Maybe_6989586621679034926"))) diff --git a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.hs b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.hs new file mode 100644 --- /dev/null +++ b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE QuasiQuotes #-} + +{-# OPTIONS_GHC -Wall -Werror -Wno-name-shadowing -ddump-splices #-} + +-- Positive: Scoping regression test. Nested pattern var 'k' from 'Add (Num k) _' +-- is used in one branch of a nested case on SMaybe, while a sibling branch shadows +-- 'k' with a let binding. Old scope-unaware freeVars would drop the accessor binding +-- for 'k', causing a compilation error. See also PCase77 for the pCase counterpart. +module T where + +import Expr +import Data.SBV + +t :: SExpr -> SMaybe Integer -> SInteger +t e m = [sCase| e of + Zero -> 0 + Num _ -> 0 + Var _ -> 0 + Add (Num k) _ -> case m of + Nothing -> let k = 42 in k + Just v -> k + v + Add _ _ -> 0 + Let _ _ _ -> 0 + |] diff --git a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.stderr b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.stderr new file mode 100644 --- /dev/null +++ b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase107.stderr @@ -0,0 +1,31 @@ +SCase107.hs:(15,16)-(24,9): Splicing expression + ghc-internal:GHC.Internal.TH.Quote.quoteExp + sCase + " e of\n\ + \ Zero -> 0\n\ + \ Num _ -> 0\n\ + \ Var _ -> 0\n\ + \ Add (Num k) _ -> case m of\n\ + \ Nothing -> let k = 42 in k\n\ + \ Just v -> k + v\n\ + \ Add _ _ -> 0\n\ + \ Let _ _ _ -> 0\n\ + \ " + ======> + ite + (isZero e) 0 + (ite + (isNum e) ((\ _ -> 0) (getNum_1 e)) + (ite + (isVar e) ((\ _ -> 0) (getVar_1 e)) + (ite + ((.&&) + (isAdd e) + ((\ _ _ -> isNum (getAdd_1 e)) (getAdd_1 e) (getAdd_2 e))) + ((\ _ _ + -> let k = getNum_1 (getAdd_1 e) + in Data.SBV.Maybe.sCaseMaybe (let k = 42 in k) (\ v -> k + v) m) + (getAdd_1 e) (getAdd_2 e)) + (ite + (isAdd e) ((\ _ _ -> 0) (getAdd_1 e) (getAdd_2 e)) + ((\ _ _ _ -> 0) (getLet_1 e) (getLet_2 e) (getLet_3 e)))))) diff --git a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.stderr b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.stderr --- a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.stderr +++ b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase59.stderr @@ -24,4 +24,4 @@ ((\ _ -> Data.SBV.Either.isRight (Data.SBV.Maybe.getJust_1 m)) (Data.SBV.Maybe.getJust_1 m))) ((\ _ -> 1) (Data.SBV.Maybe.getJust_1 m)) - (symWithKind "unmatched_sCase_Maybe_6989586621679034927"))) + (symWithKind "unmatched_sCase_Maybe_6989586621679034926"))) diff --git a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.stderr b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.stderr --- a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.stderr +++ b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase66.stderr @@ -30,4 +30,4 @@ (ite (Data.SBV.Either.isRight e) ((\ _ -> 1) (Data.SBV.Either.getRight_1 e)) - (symWithKind "unmatched_sCase_Either_6989586621679034889"))) + (symWithKind "unmatched_sCase_Either_6989586621679034888"))) diff --git a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.stderr b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.stderr --- a/SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.stderr +++ b/SBVTestSuite/TestSuite/CompileTests/SCase/SCase89.stderr @@ -40,4 +40,4 @@ (isVar e) ((\ _ -> 1) (getVar_1 e)) (ite (isLet e) ((\ _ _ _ -> 3) (getLet_1 e) (getLet_2 e) (getLet_3 e)) - (symWithKind "unmatched_sCase_Expr_6989586621679081395")))))) + (symWithKind "unmatched_sCase_Expr_6989586621679081419")))))) diff --git a/SBVTestSuite/TestSuite/Overflows/Arithmetic.hs b/SBVTestSuite/TestSuite/Overflows/Arithmetic.hs --- a/SBVTestSuite/TestSuite/Overflows/Arithmetic.hs +++ b/SBVTestSuite/TestSuite/Overflows/Arithmetic.hs @@ -11,7 +11,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ScopedTypeVariables #-} diff --git a/SBVTestSuite/TestSuite/Overflows/Casts.hs b/SBVTestSuite/TestSuite/Overflows/Casts.hs --- a/SBVTestSuite/TestSuite/Overflows/Casts.hs +++ b/SBVTestSuite/TestSuite/Overflows/Casts.hs @@ -9,7 +9,7 @@ -- Test suite for overflow checking ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -Wall -Werror #-} diff --git a/SBVTestSuite/TestSuite/Queries/Tables.hs b/SBVTestSuite/TestSuite/Queries/Tables.hs --- a/SBVTestSuite/TestSuite/Queries/Tables.hs +++ b/SBVTestSuite/TestSuite/Queries/Tables.hs @@ -12,7 +12,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE QuantifiedConstraints #-} {-# OPTIONS_GHC -Wall -Werror -Wno-orphans #-} diff --git a/SBVTestSuite/TestSuite/QuickCheck/QC.hs b/SBVTestSuite/TestSuite/QuickCheck/QC.hs --- a/SBVTestSuite/TestSuite/QuickCheck/QC.hs +++ b/SBVTestSuite/TestSuite/QuickCheck/QC.hs @@ -9,7 +9,7 @@ -- Quick-check based test suite for SBV ----------------------------------------------------------------------------- -{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE RankNTypes #-} {-# OPTIONS_GHC -Wall -Werror #-} diff --git a/sbv.cabal b/sbv.cabal --- a/sbv.cabal +++ b/sbv.cabal @@ -1,7 +1,7 @@ Cabal-Version: 2.2 Name : sbv -Version : 14.0 +Version : 14.1 Category : Formal Methods, Theorem Provers, Bit vectors, Symbolic Computation, Math, SMT Synopsis : SMT Based Verification: Symbolic Haskell theorem prover using SMT solving. Description : Express properties about Haskell programs and automatically prove them using SMT @@ -62,6 +62,7 @@ MultiParamTypeClasses NamedFieldPuns NegativeLiterals + NumericUnderscores OverloadedLists OverloadedRecordDot OverloadedStrings @@ -69,7 +70,6 @@ ParallelListComp QuantifiedConstraints QuasiQuotes - Rank2Types RankNTypes RecordWildCards ScopedTypeVariables @@ -83,12 +83,9 @@ TypeOperators UndecidableInstances ViewPatterns - - if impl(ghc >= 9.8.1) - other-extensions: TypeAbstractions + TypeAbstractions - if impl(ghc >= 8.10.1) - ghc-options : -Wunused-packages + ghc-options : -Wunused-packages Library import : common-settings