diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,10 +6,70 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## [0.6.0.0] +## [0.7.0.0] - 2024-07-02 ### Added +- Added `true` and `false` in `LogicalOp`. + ([#211](https://github.com/lsrcz/grisette/pull/211)) +- Exported the `FP` constructs in the `Grisette` module. + ([#209](https://github.com/lsrcz/grisette/pull/209)) +- Added missing `AllSyms` instance for `WordN`, `IntN`, and `FP`. + ([#209](https://github.com/lsrcz/grisette/pull/209)) +- Added unified interfaces. + ([#210](https://github.com/lsrcz/grisette/pull/210), + [#212](https://github.com/lsrcz/grisette/pull/212), + [#213](https://github.com/lsrcz/grisette/pull/213), + [#214](https://github.com/lsrcz/grisette/pull/214), + [#215](https://github.com/lsrcz/grisette/pull/215), + [#217](https://github.com/lsrcz/grisette/pull/217)) +- Added `IEEEFPRoundingMode`. + ([#219](https://github.com/lsrcz/grisette/pull/219)) +- Added `Show` instance for `SomeSym`. + ([#219](https://github.com/lsrcz/grisette/pull/219)) +- Added incoherent conversions (`ToSym`, `ToCon`) from/to `Identity a` and `a`. + ([#221](https://github.com/lsrcz/grisette/pull/221)) +### Fixed +- Fixed the printing of FP terms. + ([#219](https://github.com/lsrcz/grisette/pull/219)) + +### Changed +- [Breaking] Relaxed constraints for type classes, according to + https://github.com/haskell/core-libraries-committee/issues/10. One problem + this causes is that the instances for `Union` will no longer be able to always + merge the results. This is unfortunate, but should not be critical. + ([#213](https://github.com/lsrcz/grisette/pull/213), + [#214](https://github.com/lsrcz/grisette/pull/214), + [#221](https://github.com/lsrcz/grisette/pull/221)) +- [Breaking] Rewritten the generic derivation mechanism. + ([#213](https://github.com/lsrcz/grisette/pull/213), + [#214](https://github.com/lsrcz/grisette/pull/214), + [#216](https://github.com/lsrcz/grisette/pull/216)) +- [Breaking] Changed the type class hierarchy for operations for functors, e.g. + `SEq1`, as described in + https://github.com/haskell/core-libraries-committee/issues/10. + ([#216](https://github.com/lsrcz/grisette/pull/216)) +- [Breaking] Renamed `UnionMergeable1` to `SymBranching`. Renamed `Union` to + `UnionBase`, and `UnionM` to `Union`. + ([#214](https://github.com/lsrcz/grisette/pull/214), + [#217](https://github.com/lsrcz/grisette/pull/217)) +- [Breaking] Renamed `EvaluateSym` to `EvalSym`. Renamed `SubstituteSym` to + `SubstSym`. Renamed `ExtractSymbolics` to `ExtractSym`. + ([#217](https://github.com/lsrcz/grisette/pull/217)) +- [Breaking] Renamed `SEq` to `SymEq`. Renamed `SOrd` to `SymOrd`. + ([#217](https://github.com/lsrcz/grisette/pull/217)) +- [Breaking] Renamed `GPretty` to `PPrint`. + ([#217](https://github.com/lsrcz/grisette/pull/217), + [#224](https://github.com/lsrcz/grisette/pull/224)) +- [Breaking] Discourage the use of approximation with `approx`. `precise` is now + the default and we do not require `precise` to be used everytime we call a + solver. + ([#218](https://github.com/lsrcz/grisette/pull/218)) + +## [0.6.0.0] -- 2024-06-07 + +### Added + - Added solving procedures with solver handles. ([#198](https://github.com/lsrcz/grisette/pull/198)) - Added `overestimateUnionValues`. @@ -319,7 +379,8 @@ - Initial release for Grisette. -[Unreleased]: https://github.com/lsrcz/grisette/compare/v0.6.0.0...HEAD +[Unreleased]: https://github.com/lsrcz/grisette/compare/v0.7.0.0...HEAD +[0.7.0.0]: https://github.com/lsrcz/grisette/compare/v0.6.0.0...v0.7.0.0 [0.6.0.0]: https://github.com/lsrcz/grisette/compare/v0.5.0.1...v0.6.0.0 [0.5.0.1]: https://github.com/lsrcz/grisette/compare/v0.5.0.0...v0.5.0.1 [0.5.0.0]: https://github.com/lsrcz/grisette/compare/v0.4.1.0...v0.5.0.0 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,65 +1,28 @@ -Copyright (c) 2021-2024, Sirui Lu (siruilu@cs.washington.edu) +BSD 3-Clause License -All rights reserved. +Copyright (c) 2021-2024, Sirui Lu (siruilu@cs.washington.edu) Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. - * Neither the name of the developer (Sirui Lu) nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -------------------------------------------------------------------------------- - -This repository contains code from the parameterized-utils package: - -Copyright (c) 2013-2022 Galois Inc. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in - the documentation and/or other materials provided with the - distribution. - - * Neither the name of Galois, Inc. nor the names of its contributors - may be used to endorse or promote products derived from this - software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -49,7 +49,7 @@ ```cabal library ... - build-depends: grisette >= 0.6 < 0.7 + build-depends: grisette >= 0.7 < 0.8 ``` #### Quick start template with `stack new` @@ -63,7 +63,7 @@ You can specify the resolver version with the parameters: ```bash -$ stack new a-new-project github:lsrcz/grisette -p "resolver:lts-19.33" +$ stack new a-new-project github:lsrcz/grisette -p "resolver:lts-22.27" ``` For more details, please see the @@ -81,12 +81,12 @@ ### Install SMT Solvers -To run the examples, you also need to install an SMT solver and make it -available through `PATH`. We recommend that you start with +To run the examples, you need to install an SMT solver and make it available +through `PATH`. We recommend that you start with [Z3](https://github.com/Z3Prover/z3), as it supports all our examples and is -usually easier to install. -[Boolector](https://github.com/Boolector/boolector) is significantly more -efficient on some examples, but it does not support all of the examples. +usually easier to install. [Boolector](https://github.com/Boolector/boolector) +and its successor [Bitwuzla](https://github.com/bitwuzla/bitwuzla) are usually +significantly more efficient on bit vectors. #### Install Z3 @@ -106,33 +106,41 @@ Please refer to the [Z3 homepage](https://github.com/Z3Prover/z3) for the build instructions. -#### Install Boolector +#### Install Boolector/Bitwuzla -Boolector from major package managers are usually outdated or inexist. We -recommend that you build Boolector from source with the CaDiCaL SAT solver, -which is usually more efficient on our examples. -Please refer to the [Boolector homepage](https://github.com/Boolector/boolector) -for the build instructions. +Boolector/Bitwuzla from major package managers are usually outdated or inexist. +We recommend that you build them from source with the CaDiCaL SAT solver. Please +refer to the [Boolector homepage](https://github.com/Boolector/boolector) and +[Bitwuzla homepage](https://github.com/bitwuzla/bitwuzla) for the build +instructions. ## Example -The following example uses Grisette to build a synthesizer of arithmetic programs. Given the input-output pair (2,5), the synthesizer may output the program (\x -> x+3). The example is adapted from [this blog +The following example uses Grisette to build a synthesizer of arithmetic +programs. Given the input-output pair (2,5), the synthesizer can tell us that +the program `\x -> x+3` has the desired behavior. The example is adapted from +[this blog post](https://www.cs.utexas.edu/~bornholt/post/building-synthesizer.html) by James Bornholt. The example has three parts: - We define the arithmetic language. The language is _symbolic_: - - its syntax tree represents a set of concrete syntax trees, and - - its interpreter accepts such symbolic syntax trees, and interprete at once all represented concrete syntax trees. -- We define the candidate program space of the synthesizer by creating a particular symbolic syntax tree. The synthesizer will search the space of concrete trees for a solution. -- We interpret the symbolic syntax tree and pass the resulting constraints to the solver. If a solution exists, the solver returns a concrete tree that agrees with the input-out example. + - its syntax tree represents a set of concrete syntax trees (i.e., + representing a program space), and + - its interpreter accepts such symbolic syntax trees (program spaces), and + interpret all represented concrete syntax trees to symbolic formulas. +- We define the candidate program space of the synthesizer by creating a + particular symbolic syntax tree. The synthesizer will search the space of + concrete trees for a solution. +- We interpret the symbolic syntax tree and pass the resulting constraints to + the solver. If a solution exists, the solver returns a concrete tree that + agrees with the input-output example. ### Defining the Arithmetic Language -We will synthesize single-input programs in this example. -A single input program will be `\x -> E`, where `E` is an expression defined by -the following grammar: +We will synthesize a single-input program `\x -> E` in this example. Here the +`E` is an expression type, and is defined by the following grammar. ``` E -> c -- constant @@ -141,114 +149,119 @@ | E * E -- multiplication ``` -The syntax defines how a concrete expression is represented. To synthesis a -program, we need to define symbolic program spaces. This relies on the `UnionM` -container provided by the library to represent multiple ASTs compactly in a -single value. - -To make this expression space type work with Grisette, a set of type classes -should be derived. This includes `Mergeable`, `EvaluateSym`, etc. -The `Mergeable` type classes allows to represent multiple ASTs compactly in a -`UnionM`, while the `EvaluateSym` type class allows to evaluate it given a model -returned by a solver to replace the symbolic holes inside to concrete values. +The syntax defines how a concrete expression is represented. To synthesize a +program, we need to define ***symbolic*** program spaces. We do this with the +`Union` container provided by Grisette to represent choices within multiple ASTs +compactly in a single value. ```haskell -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - -import Grisette -import GHC.Generics - -data SExpr - -- `SConst` represents a constant in the syntax tree. +data SymExpr + -- `SymConst` represents a constant in the syntax tree. -- - -- `SConst 1` is the constant 1, while `SConst "c1"` is a symbolic constant, - -- and the solver can be used to find out what the concrete value should be. - = SConst SymInteger - -- `SInput` is very similar to the `SConst`, but is for inputs. We separate - -- these two mainly for clarity. - | SInput SymInteger - -- `SPlus` and `SMul` represent the addition and multiplication operators. + -- `SymConst 1` is the constant 1, while `SymConst "c1"` is a symbolic + -- constant, representing a hole in the expression. The solver can be used to + -- find out what the concrete value for a symbolic constant should be. + = SymConst SymInteger + -- `SymInput` is exactly the same as `SymConst`, but is for inputs. We + -- separate them just for clarity. + | SymInput SymInteger + -- `SymAdd` and `SymMul` represent the addition and multiplication operators. -- - -- The children are **sets** of symbolic programs. Here `UnionM`s are such - -- sets. + -- The children are **choices** from some symbolic expressions, which is + -- represented by the `Union` monadic container. -- - -- The solver will try to pick one concrete program from the set of programs. - | SPlus (UnionM SExpr) (UnionM SExpr) - | SMul (UnionM SExpr) (UnionM SExpr) - -- `Generic` helps us derive other type class instances for `SExpr`. + -- The solver will try to pick one choice from them. + | SymAdd (Union SymExpr) (Union SymExpr) + | SymMul (Union SymExpr) (Union SymExpr) + -- `Generic` helps us derive other type class instances for `SymExpr`. deriving stock (Generic, Show) -- Some type classes provided by Grisette for building symbolic evaluation -- tools. See the documentation for more details. - deriving (Mergeable, EvaluateSym) - via (Default SExpr) + deriving (Mergeable, EvalSym) via (Default SymExpr) --- A template haskell procedure to help the construction of `SExpr` sets. +-- The following template haskell procedures can also derive the instances we +-- need. +-- derive ''SymExpr [''Generic, ''Show, ''Mergeable, ''EvalSym] +-- deriveAllExcept ''SymExpr [''Ord] +``` + +Some smart constructors help us build program spaces. + +```haskell +-- A template haskell procedure generates smart constructors for +-- `Union SymExpr`. -- --- >>> SConst 1 :: SExpr --- SConst 1 --- >>> mrgSConst 1 :: UnionM SExpr --- {SConst 1} -mkMergeConstructor "mrg" ''SExpr +-- >>> SymConst 1 :: SymExpr +-- SymConst 1 +-- >>> mrgSymConst 1 :: Union SymExpr +-- {SymConst 1} +mkMergeConstructor "mrg" ''SymExpr ``` -Then we can define the program space. -The following code defines a program space `\x -> x + {x, c}`. Some example -programs in this space are `\x -> x + x`, `\x -> x + 1`, and `\x -> x + 2`. -The solver will be used to choose the right hand side of the addition. It may -choose to use the input variable `x`, or synthesize a constant `c`. +Then, the following code defines a program space `\x -> x + {x, c}`. Some +example programs in this space are `\x -> x + x`, `\x -> x + 1`, and `\x -> x + +2`. The solver will be used to choose the right hand side of the addition. It +may choose to use the input variable `x`, or synthesize a constant `c`. ```haskell -space :: SymInteger -> SExpr -space x = SPlus - (mrgSInput x) - (mrgIf "choice" (mrgSInput x) (mrgSConst "c")) +progSpace :: SymInteger -> SymExpr +progSpace x = + SymAdd + (mrgSymInput x) + (mrgIf "choice" (mrgSymInput x) (mrgSymConst "c")) ``` -We then need to convert this program space to its logical encoding, and we do this by writing an interpreter to interpret all the -expressions represented by an `SExpr` all at once. The interpreter looks very -similar to a normal interpreter, except that the `onUnion` combinator is used -to lift the interpreter to work on `UnionM` values. +We can then convert this program space to its logical encoding and reason about +it. This is done simply writing an interpreter to interpret all the expressions +represented by an `SymExpr` all at once. +The interpreter is similar to a concrete interpreter, except that the `onUnion` +combinator is used to lift the interpreter to work on `Union` values (a space of +expressions). + ```haskell -interpret :: SExpr -> SymInteger -interpret (SConst x) = x -interpret (SInput x) = x -interpret (SPlus x y) = interpretU x + interpretU y -interpret (SMul x y) = interpretU x * interpretU y +interpret :: SymExpr -> SymInteger +interpret (SymConst x) = x +interpret (SymInput x) = x +interpret (SymAdd x y) = interpretSpace x + interpretSpace y +interpret (SymMul x y) = interpretSpace x * interpretSpace y --- interpet a set of programs -interpretU :: UnionM SExpr -> SymInteger -interpretU = onUnion interpret +-- interpret a program space +interpretSpace :: Union SymExpr -> SymInteger +interpretSpace = onUnion interpret ``` -And we can compose the interpreter with the program space to get it executable. +We can then compose the interpreter with the program space to make it +executable. ```haskell executableSpace :: Integer -> SymInteger executableSpace = interpret . space . toSym ``` -Then we can do synthesis. We call the program space on the input 2, and construct the constraint that the result is equal to 5. We then call the solver with the `solve` function. The solver is able to find a solution, and it will return the assignments to the symbolic constants as a model. +Then we can do synthesis. We call the program space on the input 2, and +construct the constraint that the result is equal to 5. We then call the solver +with the `solve` function. The solver finds a solution such that the condition +evaluates to true. It returns the solution as a *model*, which contains an +assignment to the symbolic constants (holes). -We can then use the model to evaluate the program space, and get the synthesized program. +We can then get the synthesized program by evaluating the program space with the +model. ```haskell example :: IO () example = do - Right model <- solve (precise z3) $ executableSpace 2 .== 5 - print $ evaluateSym False model (space "x") - -- result: SPlus {SInput x} {SConst 3} + Right model <- solve z3 $ executableSpace 2 .== 5 + -- result: SymPlus {SymInput x} {SymConst 3} + print $ evalSym False model (progSpace "x") let synthesizedProgram :: Integer -> Integer = - evaluateSymToCon model . executableSpace - print $ synthesizedProgram 10 + evalSymToCon model . executableSpace -- result: 13 + print $ synthesizedProgram 10 ``` -For more details, please refer to [the Grisette examples](https://github.com/lsrcz/grisette-examples) (WIP). +The complete code is at [examples/basic/Main.hs](examples/basic/Main.hs). More +examples are available in Grisette's [tutorials](tutorials). ## Documentation @@ -263,11 +276,25 @@ ## Note +### Floating-points + Grisette currently supports boolean, uninterpreted functions, bitvector, integer, and floating point theories. However, if you want to use the floating point theory, please make sure that you have the latest libBF (>=0.6.8) and sbv installed (>=10.10.6). We've detected and fixed several bugs that would prevent a sound reasoning for floating points. + +### Unified interfaces + +Since 0.7.0.0, Grisette provides a [unified +interface](https://hackage.haskell.org/package/grisette/docs/Grisette-Unified.html) +to symbolic and concrete evaluations. GHC 9.0 or earlier, without the +[QuickLook](https://dl.acm.org/doi/10.1145/3408971) type inference algorithm for +impredicative types, may fail to resolve some constraints . You may need to +provide additional constraints in your code to help the compiler. + +If you don't use the unified interface, Grisette should work fine with GHC 8.10 +or later. ## Citing Grisette diff --git a/grisette.cabal b/grisette.cabal --- a/grisette.cabal +++ b/grisette.cabal @@ -5,16 +5,24 @@ -- see: https://github.com/sol/hpack name: grisette -version: 0.6.0.0 +version: 0.7.0.0 synopsis: Symbolic evaluation as a library description: Grisette is a reusable symbolic evaluation library for Haskell. By translating programs into constraints, Grisette can help the development of program reasoning tools, including verification, synthesis, and more. . - This "Grisette" module exports all you need for building a symbolic evaluation - tool. + The "Grisette" module exports all the core APIs for building a symbolic + evaluation tool. A high-level overview of the module structures are available + there. . - For more details, please checkout the README. + A detailed introduction to Grisette is available at "Grisette.Core". More + lifted libraries are provided in @Grisette.Lib.*@ modules. + . + The "Grisette.Unified" module offers an experimental unified interface for + symbolic and concrete evaluation. This module should be imported qualified. + . + For more details, please checkout the README and + [tutorials](https://github.com/lsrcz/grisette/tree/main/tutorials). category: Formal Methods, Theorem Provers, Symbolic Computation, SMT homepage: https://github.com/lsrcz/grisette#readme bug-reports: https://github.com/lsrcz/grisette/issues @@ -58,34 +66,34 @@ Grisette.Internal.Backend.SymBiMap Grisette.Internal.Core.Control.Exception Grisette.Internal.Core.Control.Monad.CBMCExcept + Grisette.Internal.Core.Control.Monad.Class.Union Grisette.Internal.Core.Control.Monad.Union - Grisette.Internal.Core.Control.Monad.UnionM Grisette.Internal.Core.Data.Class.BitCast Grisette.Internal.Core.Data.Class.BitVector Grisette.Internal.Core.Data.Class.CEGISSolver Grisette.Internal.Core.Data.Class.Error - Grisette.Internal.Core.Data.Class.EvaluateSym - Grisette.Internal.Core.Data.Class.ExtractSymbolics + Grisette.Internal.Core.Data.Class.EvalSym + Grisette.Internal.Core.Data.Class.ExtractSym Grisette.Internal.Core.Data.Class.Function Grisette.Internal.Core.Data.Class.GenSym - Grisette.Internal.Core.Data.Class.GPretty Grisette.Internal.Core.Data.Class.IEEEFP Grisette.Internal.Core.Data.Class.ITEOp Grisette.Internal.Core.Data.Class.LogicalOp Grisette.Internal.Core.Data.Class.Mergeable Grisette.Internal.Core.Data.Class.ModelOps Grisette.Internal.Core.Data.Class.PlainUnion + Grisette.Internal.Core.Data.Class.PPrint Grisette.Internal.Core.Data.Class.SafeDivision Grisette.Internal.Core.Data.Class.SafeLinearArith Grisette.Internal.Core.Data.Class.SafeSymRotate Grisette.Internal.Core.Data.Class.SafeSymShift - Grisette.Internal.Core.Data.Class.SEq Grisette.Internal.Core.Data.Class.SignConversion Grisette.Internal.Core.Data.Class.SimpleMergeable Grisette.Internal.Core.Data.Class.Solvable Grisette.Internal.Core.Data.Class.Solver - Grisette.Internal.Core.Data.Class.SOrd - Grisette.Internal.Core.Data.Class.SubstituteSym + Grisette.Internal.Core.Data.Class.SubstSym + Grisette.Internal.Core.Data.Class.SymEq + Grisette.Internal.Core.Data.Class.SymOrd Grisette.Internal.Core.Data.Class.SymRotate Grisette.Internal.Core.Data.Class.SymShift Grisette.Internal.Core.Data.Class.ToCon @@ -93,8 +101,7 @@ Grisette.Internal.Core.Data.Class.TryMerge Grisette.Internal.Core.Data.MemoUtils Grisette.Internal.Core.Data.Symbol - Grisette.Internal.Core.Data.Union - Grisette.Internal.Core.TH.MergeConstructor + Grisette.Internal.Core.Data.UnionBase Grisette.Internal.SymPrim.AllSyms Grisette.Internal.SymPrim.BV Grisette.Internal.SymPrim.FP @@ -131,6 +138,16 @@ Grisette.Internal.SymPrim.SymInteger Grisette.Internal.SymPrim.SymTabularFun Grisette.Internal.SymPrim.TabularFun + Grisette.Internal.TH.DeriveBuiltin + Grisette.Internal.TH.DeriveInstanceProvider + Grisette.Internal.TH.DerivePredefined + Grisette.Internal.TH.DeriveTypeParamHandler + Grisette.Internal.TH.DeriveUnifiedInterface + Grisette.Internal.TH.DeriveWithHandlers + Grisette.Internal.TH.MergeConstructor + Grisette.Internal.TH.UnifiedConstructor + Grisette.Internal.TH.Util + Grisette.Internal.Utils.Derive Grisette.Internal.Utils.Parameterized Grisette.Lib.Base Grisette.Lib.Control.Applicative @@ -154,6 +171,31 @@ Grisette.Lib.Data.Traversable Grisette.Lib.Data.Tuple Grisette.SymPrim + Grisette.TH + Grisette.Unified + Grisette.Unified.Internal.BaseConstraint + Grisette.Unified.Internal.BaseMonad + Grisette.Unified.Internal.Class.UnifiedITEOp + Grisette.Unified.Internal.Class.UnifiedSafeDivision + Grisette.Unified.Internal.Class.UnifiedSafeLinearArith + Grisette.Unified.Internal.Class.UnifiedSafeSymRotate + Grisette.Unified.Internal.Class.UnifiedSafeSymShift + Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + Grisette.Unified.Internal.Class.UnifiedSymEq + Grisette.Unified.Internal.Class.UnifiedSymOrd + Grisette.Unified.Internal.EvalMode + Grisette.Unified.Internal.EvalModeTag + Grisette.Unified.Internal.MonadWithMode + Grisette.Unified.Internal.UnifiedBool + Grisette.Unified.Internal.UnifiedBV + Grisette.Unified.Internal.UnifiedConstraint + Grisette.Unified.Internal.UnifiedData + Grisette.Unified.Internal.UnifiedInteger + Grisette.Unified.Internal.Util + Grisette.Unified.Lib.Control.Applicative + Grisette.Unified.Lib.Control.Monad + Grisette.Unified.Lib.Data.Foldable + Grisette.Unified.Lib.Data.Functor Grisette.Utils other-modules: Paths_grisette @@ -166,6 +208,7 @@ , async >=2.2.2 && <2.3 , base >=4.14 && <5 , bytestring >=0.10.12 && <0.13 + , containers >=0.4 && <0.8 , deepseq >=1.4.4 && <1.6 , generic-deriving >=1.14.1 && <1.15 , hashable >=1.2.3 && <1.5 @@ -179,6 +222,7 @@ , stm ==2.5.* , template-haskell >=2.16 && <2.23 , text >=1.2.4.1 && <2.2 + , th-abstraction >=0.4 && <0.8 , th-compat >=0.1.2 && <0.2 , transformers >=0.5.6 && <0.7 , unordered-containers >=0.2.11 && <0.3 @@ -203,6 +247,7 @@ , async >=2.2.2 && <2.3 , base >=4.14 && <5 , bytestring >=0.10.12 && <0.13 + , containers >=0.4 && <0.8 , deepseq >=1.4.4 && <1.6 , doctest >=0.18.2 && <0.23 , generic-deriving >=1.14.1 && <1.15 @@ -218,6 +263,7 @@ , stm ==2.5.* , template-haskell >=2.16 && <2.23 , text >=1.2.4.1 && <2.2 + , th-abstraction >=0.4 && <0.8 , th-compat >=0.1.2 && <0.2 , transformers >=0.5.6 && <0.7 , unordered-containers >=0.2.11 && <0.3 @@ -236,29 +282,30 @@ Grisette.Backend.TermRewritingGen Grisette.Backend.TermRewritingTests Grisette.Core.Control.ExceptionTests - Grisette.Core.Control.Monad.UnionMTests Grisette.Core.Control.Monad.UnionTests Grisette.Core.Data.Class.BoolTests - Grisette.Core.Data.Class.EvaluateSymTests - Grisette.Core.Data.Class.ExtractSymbolicsTests + Grisette.Core.Data.Class.EvalSymTests + Grisette.Core.Data.Class.ExtractSymTests Grisette.Core.Data.Class.GenSymTests - Grisette.Core.Data.Class.GPrettyTests Grisette.Core.Data.Class.MergeableTests Grisette.Core.Data.Class.PlainUnionTests + Grisette.Core.Data.Class.PPrintTests Grisette.Core.Data.Class.SafeDivisionTests Grisette.Core.Data.Class.SafeLinearArithTests Grisette.Core.Data.Class.SafeSymRotateTests Grisette.Core.Data.Class.SafeSymShiftTests - Grisette.Core.Data.Class.SEqTests Grisette.Core.Data.Class.SimpleMergeableTests - Grisette.Core.Data.Class.SOrdTests - Grisette.Core.Data.Class.SubstituteSymTests + Grisette.Core.Data.Class.SubstSymTests + Grisette.Core.Data.Class.SymEqTests + Grisette.Core.Data.Class.SymOrdTests Grisette.Core.Data.Class.SymRotateTests Grisette.Core.Data.Class.SymShiftTests Grisette.Core.Data.Class.TestValues Grisette.Core.Data.Class.ToConTests Grisette.Core.Data.Class.ToSymTests Grisette.Core.Data.Class.TryMergeTests + Grisette.Core.Data.UnionBaseTests + Grisette.Core.TH.DerivationTest Grisette.Lib.Control.ApplicativeTest Grisette.Lib.Control.Monad.ExceptTests Grisette.Lib.Control.Monad.State.ClassTests @@ -287,6 +334,9 @@ Grisette.TestUtil.NoMerge Grisette.TestUtil.PrettyPrint Grisette.TestUtil.SymbolicAssertion + Grisette.Unified.EvalModeTest + Grisette.Unified.UnifiedClassesTest + Grisette.Unified.UnifiedConstructorTest Paths_grisette hs-source-dirs: test @@ -298,6 +348,7 @@ , async >=2.2.2 && <2.3 , base >=4.14 && <5 , bytestring >=0.10.12 && <0.13 + , containers >=0.4 && <0.8 , deepseq >=1.4.4 && <1.6 , generic-deriving >=1.14.1 && <1.15 , grisette @@ -315,6 +366,7 @@ , test-framework-hunit >=0.3.0.2 && <0.4 , test-framework-quickcheck2 >=0.3.0.5 && <0.4 , text >=1.2.4.1 && <2.2 + , th-abstraction >=0.4 && <0.8 , th-compat >=0.1.2 && <0.2 , transformers >=0.5.6 && <0.7 , unordered-containers >=0.2.11 && <0.3 diff --git a/src/Grisette.hs b/src/Grisette.hs --- a/src/Grisette.hs +++ b/src/Grisette.hs @@ -3,27 +3,73 @@ -- | -- Module : Grisette --- Copyright : (c) Sirui Lu 2021-2023 +-- Copyright : (c) Sirui Lu 2021-2024 -- License : BSD-3-Clause (see the LICENSE file) -- -- Maintainer : siruilu@cs.washington.edu -- Stability : Experimental -- Portability : GHC only module Grisette - ( -- * Core modules - module Grisette.Core, + ( -- | Grisette is a tool for performing symbolic evaluation on programs. With + -- Grisette, you can construct your own symbolic DSL and obtain the symbolic + -- evaluator for it without manually implementing the symbolic evaluation + -- algorithms. A brief introduction to symbolic evaluation is available in + -- the "Grisette.Core" module. + -- + -- This module exports most of the Grisette APIs. Additional lifted library + -- constructs are in the submodules of @Grisette.Lib@, which are not + -- exported here and should be imported explicitly. For example, to use + -- the lifted "Data.List" functions, you should import + -- "Grisette.Lib.Data.List" explicitly. + -- + -- Grisette also provides an experimental API for unifying symbolic and + -- concrete code to avoid code duplication. This API is exported in the + -- "Grisette.Unified" module. The module should be imported qualified, as + -- it intentionally uses the same names as the "Grisette" module. + -- + -- The following shows a typical import list: + -- + -- > import Grisette + -- > import Grisette.Lib.Data.List + -- > import qualified Grisette.Unified as U + -- > import qualified Grisette.Unified.Lib.Data.List as U + -- + -- Other highly experimental APIs are exported in "Grisette.Experimental" + -- and its submodules. These APIs are not stable, may be buggy and poorly + -- maintained, and do not follow the PVP rules. - -- * Core libraries - module Grisette.Lib.Base, + -- * Core modules + -- | This module exports the core operations for manipulating symbolic + -- values. + module Grisette.Core, + -- * Symbolic primitives + + -- | This module provides primitive types for symbolic evaluation. module Grisette.SymPrim, -- * Solver backend + + -- | This module provides the configuration of the solver backends. module Grisette.Backend, + -- * Core libraries + + -- | This module exports the core lifted library constructs. + module Grisette.Lib.Base, + -- * Utils + + -- | This module exports utility functions for working with size-tagged + -- types. module Grisette.Utils, + + -- * Template Haskell + + -- | This module provides template haskell procedures that help with type + -- class derivation and constructing some smart constructors. + module Grisette.TH, ) where @@ -31,4 +77,5 @@ import Grisette.Core import Grisette.Lib.Base import Grisette.SymPrim +import Grisette.TH import Grisette.Utils diff --git a/src/Grisette/Backend.hs b/src/Grisette/Backend.hs --- a/src/Grisette/Backend.hs +++ b/src/Grisette/Backend.hs @@ -10,29 +10,30 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Backend - ( -- * Grisette.Internal.SBV backend configuration + ( -- * SMT backend configuration + GrisetteSMTConfig (..), + boolector, + bitwuzla, + cvc4, + cvc5, + yices, + dReal, + z3, + mathSAT, + abc, + + -- * Changing the extra configurations ApproximationConfig (..), ExtraConfig (..), precise, - approx, + approximate, withTimeout, clearTimeout, - withApprox, - clearApprox, - GrisetteSMTConfig (..), -- * SBV backend solver configuration SBV.SMTConfig (..), - SBV.boolector, - SBV.bitwuzla, - SBV.cvc4, - SBV.cvc5, - SBV.yices, - SBV.dReal, - SBV.z3, - SBV.mathSAT, - SBV.abc, SBV.Timing (..), + SBV.SMTSolver (..), ) where @@ -41,10 +42,17 @@ ( ApproximationConfig (..), ExtraConfig (..), GrisetteSMTConfig (..), - approx, - clearApprox, + abc, + approximate, + bitwuzla, + boolector, clearTimeout, + cvc4, + cvc5, + dReal, + mathSAT, precise, - withApprox, withTimeout, + yices, + z3, ) diff --git a/src/Grisette/Core.hs b/src/Grisette/Core.hs --- a/src/Grisette/Core.hs +++ b/src/Grisette/Core.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Trustworthy #-} -- Disable this warning because we are re-exporting things. @@ -12,15 +13,59 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Core - ( -- * Note for the examples + ( -- * Organization of the module + -- | The module is organized by first introducing symbolic values, which + -- includes [solvable (primitive)](#g:solvable) types and + -- [unsolvable (non-primitive)](#g:unsolvable) types. + -- Solvable types are those directly supported by the underlying solver. + -- Examples include symbolic Booleans ('Grisette.SymPrim.SymBool'), integers + -- ('Grisette.SymPrim.SymInteger'), and bit vectors + -- (@'Grisette.SymPrim.SymWordN' n@). Other types are unsolvable. They need + -- 'Union' monadic container and 'Mergeable' instances to be merged. -- + -- We will elaborate the internal details of the symbolic values in the + -- documentation, but it is likely that you can skip them and directly go + -- through the APIs and the operations to start using Grisette. + -- + -- [Various operations](#g:symops) are provided for + -- manipulating symbolic values, including solvable and unsolvable types. + -- Apart from the basic operations for each type of symbolic values, we also + -- provide generic operations for: + -- + -- * Symbolic equality and comparison ('SymEq', 'SymOrd') + -- * Conversion between concrete and symbolic values ('ToCon', 'ToSym') + -- * Merging of symbolic values ('Mergeable', 'SimpleMergeable', 'TryMerge') + -- * Symbolic branching ('SymBranching') + -- + -- Additional tools for building symbolic evaluation based applications are + -- also provided: + -- + -- * Pretty printing (e.g., 'Format') + -- * Symbolic generation, or generating fresh symbolic values (e.g., + -- 'GenSym') + -- * Error handling (e.g., 'symAssert') + -- * Solver backend interface (e.g., 'solve', 'cegis') + -- * Substitutions for symbolic values given the solving results (e.g., + -- 'ExtractSym', 'EvalSym', 'SubstSym'). + -- + -- Finally [some utilities](#g:utils), including helpers for + -- deriving instances for the type classes are provided in this module. - -- | The examples may assume a [z3](https://github.com/Z3Prover/z3) solver available in @PATH@. + -- * Note for the examples in the documentation - -- * Symbolic values + -- | The examples may assume a [z3](https://github.com/Z3Prover/z3) solver + -- available in @PATH@. - -- | Grisette is a tool for performing symbolic evaluation on programs. + -- * Introduction to symbolic values in Grisette + + -- ** Symbolic evaluation primer + + -- | Grisette is a tool for performing symbolic evaluation on programs. With + -- Grisette, you can construct your own symbolic DSL, and get the symbolic + -- evaluator for it without the need of manually implementing the symbolic + -- evaluation algorithms. + -- -- Symbolic evaluation is a technique that allows us to analyze all -- possible runs of a program by representing inputs (or the program -- itself) as symbolic values and evaluating the program to produce @@ -29,23 +74,50 @@ -- symbolic values that meet certain criteria, such as triggering a bug in -- a verification task or satisfying a specification in a synthesis task. -- - -- One of the challenges of symbolic evaluation is the well-known path - -- explosion problem, which occurs when traditions symbolic evaluation + -- For example, in the following pseudo code, suppose that we want to know + -- whether the assertion at the end of the code will hold for all possible + -- inputs: + -- + -- > a = input() + -- > b = 4 + -- > if (a < 5) { + -- > b -= a + -- > } + -- > assert (b > 0) + -- + -- We can represent the input @a@ as a symbolic integer, and do symbolic + -- evaluation for it. By exploring __all__ possible program paths, we will + -- know that the result for the condition in the assertion would then be a + -- symbolic formula: + -- + -- > (ite (< a 5) (> (- 4 a) 0) (> 4 0)). + -- + -- The original program violates the assertion when this formula is false. + -- We can use a solver to ask whether this could happen, and solver will + -- tell us that when @a@ is 4, the assertion will not hold. + -- + -- Our resulting formula captures the information about all possible program + -- runs. One of the challenges of symbolic evaluation is the well-known path + -- explosion problem, which occurs when traditional symbolic evaluation -- techniques evaluate and reason about the possible paths one-by-one. -- This can lead to exponential growth in the number of paths that need to -- be analyzed, making the process impractical for many tasks. + -- -- To address this issue, Grisette uses a technique called "path merging". -- In path merging, symbolic values are merged together in order to reduce -- the number of paths that need to be explored simultaneously. This can -- significantly improve the performance of symbolic evaluation, especially -- for tasks such as program synthesis that are prone to the path explosion - -- problem. + -- problem. This path merging is done automatically by Grisette, with a set + -- of symbolic values. -- -- In Grisette, we make a distinction between two kinds of symbolic values: -- __/solvable types/__ and __/unsolvable types/__. These two types of -- values are merged differently. - -- - -- __/Solvable types/__ are types that are directly supported by the + + -- ** Solvable types (solver-primitive types) #solvable# + + -- | __/Solvable types/__ are types that are directly supported by the -- underlying solver and are represented as symbolic formulas. Examples -- include symbolic Booleans, integers and bit vectors. The values of -- solvable types can be __/fully/__ merged into a single value, which @@ -57,22 +129,26 @@ -- -- > x = if a then b else c -- pseudo code, not real Grisette code -- - -- The result would be a single symbolic Boolean formula: + -- The result would be a single symbolic integer formula: -- - -- > -- result: x is (ite a b c) + -- >>> x = symIte "a" "b" "c" :: SymInteger -- real Grisette code + -- >>> x + -- (ite a b c) -- -- If we further add 1 to @x@, we will not have to split to two paths, - -- but we can directly construct a formula with the merged state: - -- - -- > x + 1 - -- > -- result (+ 1 (ite a b c)) + -- but we can directly construct a formula with the merged value: -- - -- __/Unsolvable types/__, on the other hand, are types that are not + -- >>> x + 1 + -- (+ 1 (ite a b c)) + + -- ** Unsolvable types (non-solver-primitive types) #unsolvable# + + -- | __/Unsolvable types/__, on the other hand, are types that are not -- directly supported by the solver and cannot be fully merged into a -- single formula. Examples include lists, algebraic data types, and - -- concrete Haskell integer types. To symbolically evaluate values in - -- unsolvable types, Grisette provides a symbolic union container, which is - -- a set of values guarded by their path conditions. + -- concrete Haskell integer types. To symbolically evaluate values with + -- unsolvable types, Grisette provides a symbolic union container ('Union'), + -- which is a set of values guarded by their path conditions. -- The values of unsolvable types are __/partially/__ merged in a symbolic -- union, which is essentially an if-then-else tree. -- @@ -83,34 +159,59 @@ -- length: -- -- > x = if a then [b] else [c] -- pseudo code, not real Grisette code - -- > -- result: Single [(ite a b c)] -- + -- Or, in real Grisette code: + -- + -- >>> mrgIf "a" (return ["b"]) (return ["c"]) :: Union [SymBool] + -- {[(ite a b c)]} + -- + -- Note that we are using 'mrgIf' instead of 'symIte' for 'Union's. + -- -- The second example shows that @[b]@ and @[c,d]@ cannot be merged -- together because they have different lengths: -- -- > if a then [b] else [c, d] -- pseudo code, not real Grisette code - -- > -- result: If a (Single [b]) (Single [c,d]) -- + -- In real Grisette code: + -- + -- >>> mrgIf "a" (return ["b"]) (return ["c", "d"]) :: Union [SymBool] + -- {If a [b] [c,d]} + -- -- The following example is more complicated. To make the merging -- efficient, Grisette would maintain a representation invariant of the -- symbolic unions. In this case, the lists with length 1 should be placed -- at the then branch, and the lists with length 2 should be placed at the -- else branch. -- - -- > if a1 then [b] else if a2 then [c, d] else [f] -- pseudo code, not real Grisette code - -- > -- result: If (|| a1 (! a2)) (Single [(ite a1 b f)]) (Single [c,d]) + -- > x = if a1 then [b] else if a2 then [c, d] else [f] -- pseudo code, not real Grisette code -- + -- In real Grisette code: + -- + -- >>> x = mrgIf "a1" (return ["b"]) (mrgIf "a2" (return ["c", "d"]) (return ["f"])) :: Union [SymBool] + -- >>> x + -- {If (|| a1 (! a2)) [(ite a1 b f)] [c,d]} + -- -- When we further operate on this partially merged values, - -- we will need to split into multiple paths. For example, when we apply 'head' - -- onto the last result, we will distribute 'head' among the branches: + -- we will need to split into multiple paths. For example, when we apply + -- 'head' onto the last result, and we will distribute 'head' among the + -- branches: -- - -- > head (if a1 then [b] else if a2 then [c, d] else [f]) -- pseudo code, not real Grisette code + -- > head x -- pseudo code, not real Grisette code -- > -- intermediate result: If (|| a1 (! a2)) (Single (head [(ite a1 b f)])) (Single (head [c,d])) -- > -- intermediate result: If (|| a1 (! a2)) (Single (ite a1 b f)) (Single c) -- - -- Then the result would be further merged into a single value: + -- This \"path splitting\" is done with the monad instance of 'Union'. The + -- result is then merged into a single formula, and further operation on it + -- won't have to split into multiple paths: -- - -- > -- final result: Single (ite (|| a1 (! a2)) (ite a1 b f) c) + -- >>> :set -Wno-unrecognised-warning-flags -Wno-x-partial + -- >>> x = mrgIf "a1" (return ["b"]) (mrgIf "a2" (return ["c", "d"]) (return ["f"])) :: Union [SymBool] + -- >>> :{ + -- do + -- v <- x -- Path splitted with the (>>=) + -- mrgReturn $ head v -- mrgReturn helps with the merging + -- :} + -- {(ite (|| a1 (! a2)) (ite a1 b f) c)} -- -- Generally, merging the possible branches in a symbolic union can reduce -- the number of paths to be explored in the future, but can make the path @@ -118,23 +219,39 @@ -- this, Grisette has built a hierarchical merging algorithm, which is -- configurable via 'MergingStrategy'. For algebraic data types, we have -- prebuilt merging strategies via the derivation of the 'Mergeable' type - -- class. You only need to know the details of the merging algorithm if you - -- are going to work with non-algebraic data types. + -- class (Also see 'GMergeable' for detail of derivation). You only need to + -- know the details of the merging algorithm if you are going to work with + -- complex non-algebraic data types, or you'd like to configure the merging + -- based on your domain knowledge to tweak the performance. - -- ** Solvable types + -- * Solvable types - -- | A solvable type is a type that can be represented as a formula and is - -- directly supported by the underlying constraint solvers. - -- Grisette - -- currently provides an implementation for the following solvable types: + -- | + -- Grisette currently provides an implementation for the following solvable + -- types: -- - -- * 'Grisette.SymPrim.SymBool' (symbolic Booleans) - -- * 'Grisette.SymPrim.SymInteger' (symbolic unbounded integers) - -- * @'Grisette.SymPrim.SymIntN' n@ (symbolic signed bit vectors of length @n@) - -- * @'Grisette.SymPrim.SymWordN' n@ (symbolic unsigned bit vectors of length @n@) + -- * 'Grisette.SymPrim.SymBool' ('Bool', symbolic Booleans) + -- * 'Grisette.SymPrim.SymInteger' ('Integer', symbolic unbounded integers) + -- * @'Grisette.SymPrim.SymIntN' n@ (@'Grisette.SymPrim.IntN' n@, symbolic + -- signed bit vectors of bit width @n@) + -- * @'Grisette.SymPrim.SymWordN' n@ (@'Grisette.SymPrim.WordN' n@, symbolic + -- unsigned bit vectors of bit width @n@) + -- * @'Grisette.SymPrim.SymFP' eb sb@ (@'Grisette.SymPrim.FP' eb sb@, + -- symbolic IEEE-754 floating point numbers with @eb@ exponent bits and + -- @sb@ significand bits) + -- * @'Grisette.SymPrim.SymBool' t'Grisette.SymPrim.=~>' 'Grisette.SymPrim.SymBool'@ + -- (@'Bool' t'Grisette.SymPrim.=->' 'Bool'@, symbolic functions, + -- uninterpreted or represented as a table for the input-outputs + -- relations). + -- * @'Grisette.SymPrim.SymBool' t'Grisette.SymPrim.-~>' 'Grisette.SymPrim.SymBool'@ + -- (@'Bool' t'Grisette.SymPrim.-->' 'Bool'@, symbolic functions, + -- uninterpreted or represented as a formula over some bound variables. -- - -- The two bit vector types has their lengths checked at compile time. - -- Grisette also provides runtime-checked versions of these types: + -- The bit-width of bit vector types and floating point types have their + -- are checked at compile time. + -- + -- Grisette also provides runtime-checked versions of bit-vectors, which + -- might be more convenient in many scenarios: -- 'Grisette.SymPrim.SomeSymIntN' and 'Grisette.SymPrim.SomeSymWordN'. -- -- Values of a solvable type can consist of concrete values, symbolic @@ -148,6 +265,10 @@ -- >>> import Grisette -- >>> con True :: SymBool -- a concrete value -- true + -- >>> true :: SymBool -- via the LogicalOp instance + -- true + -- >>> 1 :: SymInteger -- via the Num instance + -- 1 -- >>> ssym "a" :: SymBool -- a symbolic constant -- a -- @@ -159,7 +280,7 @@ -- a -- -- Symbolic operations are provided through a set of type classes, - -- such as 'SEq', 'SOrd', and 'Num'. Please check out the documentation for + -- such as 'SymEq', 'SymOrd', and 'Num'. Please check out the documentation for -- more details. -- -- __Examples:__ @@ -169,58 +290,123 @@ -- >>> a .== b -- (= a b) - -- *** Creation of solvable type values - Solvable (..), - pattern Con, + -- ** Identifiers and symbols + + -- A symbolic constant is created out of a 'Symbol'. Two symbolic constants + -- with the same type and the same 'Symbol' are the same symbolic value. + -- + -- A symbolic value is an 'Identifier' with a possible index. + -- + -- A simple symbol can be created out of a string literal: + -- + -- >>> "a" :: Symbol + -- a Identifier (..), Symbol (..), identifier, withInfo, withLoc, uniqueIdentifier, - slocsym, - ilocsym, simple, indexed, - -- *** Symbolic operators + -- ** Creation and extraction of solvable values + Solvable (..), + pattern Con, + slocsym, + ilocsym, - -- | #symop# + -- * Basic symbolic operations #symops# + + -- ** Basic logical operators LogicalOp (..), ITEOp (..), - SEq (..), - SOrd (..), + + -- ** Symbolic equality + SymEq (..), + SymEq1 (..), + symEq1, + SymEq2 (..), + symEq2, + + -- ** Symbolic comparison + SymOrd (..), + SymOrd1 (..), + symCompare1, + SymOrd2 (..), + symCompare2, symMax, symMin, mrgMax, mrgMin, + + -- ** Bit-vectors BV (..), bvExtract, SizedBV (..), sizedBVExtract, + SymShift (..), + SafeSymShift (..), + SymRotate (..), + SafeSymRotate (..), SignConversion (..), + BitCast (..), + + -- ** Safe operation for Numbers SafeDivision (..), SafeLinearArith (..), + + -- ** Functions Function (..), Apply (..), - SymShift (..), - SafeSymShift (..), - SymRotate (..), - SafeSymRotate (..), - -- ** Unsolvable types + -- ** IEEE Floating points + fpIsNaN, + fpIsPositiveZero, + fpIsNegativeZero, + fpIsPositiveInfinite, + fpIsNegativeInfinite, + fpIsPositive, + fpIsNegative, + fpIsInfinite, + fpIsZero, + fpIsNormal, + fpIsSubnormal, + fpIsPoint, + SymIEEEFPTraits (..), + IEEEConstants (..), + IEEEFPRoundingMode (..), + IEEEFPOp (..), + IEEEFPRoundingOp (..), - -- | There are types that cannot be directly represented as SMT formulas - -- and therefore not supported by the SMT solvers. These types are referred - -- to as __/unsolvable types/__. + -- ** Conversion between Concrete and Symbolic values + ToCon (..), + ToCon1 (..), + toCon1, + ToCon2 (..), + toCon2, + ToSym (..), + ToSym1 (..), + toSym1, + ToSym2 (..), + toSym2, + + -- * Unsolvable types and merging + + -- | There are types that be directly represented as SMT formulas and + -- therefore not directly supported by the SMT solvers. These types are + -- referred to as __/unsolvable types/__. -- To symbolically evaluate such types, we represent them with -- __/symbolic unions/__. -- A symbolic union is a set of multiple values from different execution -- paths, each guarded with a corresponding path condition. -- The value of a union can be determined by an SMT solver based on the -- truth value of the path conditions. - -- - -- In Grisette, the symbolic union type is 'UnionM'. + + -- ** 'Union' basics + + -- | + -- In Grisette, the symbolic union type is 'Union'. -- Two constructs are useful in constructing symbolic union values: 'mrgIf' -- and 'mrgSingle'. -- 'mrgSingle' unconditionally wraps a value in a symbolic union container, @@ -228,12 +414,12 @@ -- conditions. -- Here are some examples of using 'mrgSingle' and 'mrgIf': -- - -- >>> mrgSingle ["a"] :: UnionM [SymInteger] + -- >>> mrgSingle ["a"] :: Union [SymInteger] -- {[a]} - -- >>> mrgIf "a" (mrgSingle ["b"]) (mrgSingle ["c", "d"]) :: UnionM [SymInteger] + -- >>> mrgIf "a" (mrgSingle ["b"]) (mrgSingle ["c", "d"]) :: Union [SymInteger] -- {If a [b] [c,d]} -- - -- 'UnionM' is a monad, and its bind operation is similar to tree + -- 'Union' is a monad, and its bind operation is similar to tree -- substitution. -- This means you can then use monadic constructs to model sequential programs. -- For example, the following pseudo code can be @@ -244,10 +430,13 @@ -- > return (x ++ y :: [SymInteger]) -- -- >>> :{ - -- ret :: UnionM [SymInteger] + -- ret :: Union [SymInteger] -- ret = do x <- mrgIf "a" (return ["b"]) (return ["b","c"]) -- y <- mrgIf "d" (return ["e"]) (return ["e","f"]) - -- mrgReturn $ x ++ y -- we will explain mrgReturn later + -- -- we will explain mrgReturn later, but rule of thumb is to + -- -- always use mrg* functions if provided by Grisette and if + -- -- you don't understand what will happen with ordinary return. + -- mrgReturn $ x ++ y -- :} -- -- When this code is evaluated, the result would be as follows: @@ -260,10 +449,11 @@ -- This is important for scaling symbolic evaluation to real-world -- problems. -- - -- The 'mrgReturn' function is crucial for ensuring that the results - -- are merged. It resolves the 'Mergeable' constraint, and retrieves a - -- merging strategy for the contained type from the constraint. - -- The merging strategy is then cached in the 'UnionMBase' container to + -- The 'Grisette.Lib.Control.Monad.mrgReturn' function is crucial for + -- ensuring that the results are merged. It resolves the 'Mergeable' + -- constraint, and retrieves a merging strategy for the contained type from + -- the constraint. + -- The merging strategy is then cached in the 'Union' container to -- help merge the result of the entire do-block. -- This is necessary due to -- [the constrained-monad problem](https://dl.acm.org/doi/10.1145/2500365.2500602), @@ -273,48 +463,48 @@ -- by the knowledge propagation technique introduced in the -- [blog post](https://okmij.org/ftp/Haskell/set-monad.html#PE) by Oleg Kiselyov. -- - -- In addition to 'mrgReturn', + -- In addition to 'Grisette.Lib.Control.Monad.mrgReturn', -- Grisette provides many combinators with the @mrg@ prefix. -- You should use these combinators and always have the result cache the merging strategy. -- Consider the following code: -- - -- >>> return 1 :: UnionM Integer + -- >>> return 1 :: Union Integer -- <1> - -- >>> mrgReturn 1 :: UnionM Integer + -- >>> mrgReturn 1 :: Union Integer -- {1} - -- >>> mrgIf "a" (return 1) (return 2) :: UnionM Integer + -- >>> mrgIf "a" (return 1) (return 2) :: Union Integer -- {If a 1 2} -- - -- In the first example, using 'return' instead of 'mrgReturn' results in a - -- 'UAny' container (printed as @<@@...@@>@), which means that no merging - -- strategy is cached. - -- In the second and third example, using 'mrgReturn' or 'mrgIf' results in - -- a 'UMrg' container (printed as @{...}@), - -- which means that the merging strategy is cached. + -- In the first example, using 'return' instead of + -- 'Grisette.Lib.Control.Monad.mrgReturn' results in a unmerged container + -- (printed as @<@@...@@>@), which means that no merging strategy is cached. + -- In the second and third example, using + -- 'Grisette.Lib.Control.Monad.mrgReturn' or 'mrgIf' results in a merged + -- container (printed as @{...}@) with a cached merging strategy. -- - -- When working with 'UnionM', it is important to always use the @mrg@ prefixed - -- combinators to ensure that the merging strategy is properly cached. - -- This will enable Grisette to properly merge the results of the entire do-block - -- and scale symbolic evaluation to real-world problems. + -- When working with 'Union', it is important to always use the @mrg@ + -- prefixed combinators to ensure that the merging strategy is properly + -- cached. This will enable Grisette to properly merge the results of the + -- entire do-block and scale symbolic evaluation to real-world problems. -- Those functions that merges the results can also further propagate the - -- cached merging strategy, note that the result is merged: + -- cached merging strategy, see how the result is merged: -- - -- >>> f x y = mrgIf "f" (return x) (return y) - -- >>> do; a <- mrgIf "a" (return 1) (return 2); f a (a + 1) :: UnionM Integer + -- >>> f x y = mrgIf "f" (return x) (return y) :: Union Integer + -- >>> do; a <- mrgIf "a" (return 1) (return 2); f a (a + 1) -- {If (&& a f) 1 (If (|| a f) 2 3)} -- - -- For more details of this, see the documentation for 'UnionMBase' and - -- 'MergingStrategy'. - -- - -- To make a type compatible with the symbolic evaluation and merging in + -- For more details on this, see the documentation for 'Union', + -- 'MergingStrategy', and the [merging section](#g:merging) in + -- this module. + + -- ** Working with user-defined types + + -- | To make a type compatible with the symbolic evaluation and merging in -- Grisette, you need to implement the 'Mergeable' type class. -- If you are only working with algebraic -- data types, you can derive the 'Mergeable' instance automatically -- For example: -- - -- >>> :set -XDerivingStrategies - -- >>> :set -XDerivingVia - -- >>> :set -XDeriveGeneric -- >>> import GHC.Generics -- >>> :{ -- data X = X SymInteger Integer @@ -322,20 +512,39 @@ -- deriving (Mergeable) via (Default X) -- :} -- - -- This allows you to use the @UnionM@ type to represent values of type @X@, - -- and have them merged with the 'mrgIf' combinator: + -- Grisette also provide 'Grisette.deriveAll' template haskell procedure to + -- derive all the instances for the classes that are relevant. This include + -- 'GHC.Generics.Generic', 'Show', 'Mergeable', etc. If you only want to + -- derive some of them, you can also use 'Grisette.deriveAllExcept' or + -- 'Grisette.derive'. -- - -- >>> mrgIf "c1" (mrgSingle $ X "b" 1) (mrgIf "c2" (mrgSingle $ X "c" 2) (mrgSingle $ X "d" 1)) :: UnionM X + -- >>> :{ + -- data X = X SymInteger Integer + -- deriveAllExcept ''X [''Ord] + -- -- Ord is excluded because it is a symbolic type + -- :} + -- + -- Having the 'Mergeable' instance allows you to use the 'Union' type to + -- represent values of type @X@, and have them merged with the 'mrgIf' + -- combinator: + -- + -- >>> mrgIf "c1" (mrgSingle $ X "b" 1) (mrgIf "c2" (mrgSingle $ X "c" 2) (mrgSingle $ X "d" 1)) :: Union X -- {If (|| c1 (! c2)) (X (ite c1 b d) 1) (X c 2)} -- - -- It is also possible to apply monad transformers onto @UnionM@ to extend + -- __Note that deriving all instances may need to enable many__ + -- __extensions, see 'Grisette.deriveAll' for details.__ + + -- ** Using monad transformers + + -- | It is also possible to apply monad transformers onto 'Union' to extend -- it with various mechanisms. -- For example, by applying 'Control.Monad.Except.ExceptT', -- you can symbolically evaluate a program with error handling. -- To do this, you will need to define an error type and derive the 'Mergeable' - -- instance for it. Then, you can use the combinators provided by 'MonadError' - -- (and the @mrg*@ variants of them) for error handling, and the 'mrgIf' - -- combinator will also work with transformed @UnionM@ containers. + -- instance for it. Then, you can use the combinators provided by + -- 'Control.Monad.Except.MonadError' (and the @mrg*@ variants of them in + -- "Grisette.Lib.Control.Monad.Except") for error handling, and the 'mrgIf' + -- combinator will also work with transformed 'Union' containers. -- -- Here's an example using the 'Control.Monad.Except.ExceptT' transformer -- to model error handling in Grisette: @@ -343,18 +552,19 @@ -- >>> import Control.Monad.Except -- >>> :{ -- data Error = Fail - -- deriving (Show, Generic) - -- deriving (Mergeable) via (Default Error) + -- deriveAll ''Error -- :} -- - -- >>> mrgIf "a" (throwError Fail) (return "x") :: ExceptT Error UnionM SymInteger + -- >>> mrgIf "a" (throwError Fail) (return "x") :: ExceptT Error Union SymInteger -- ExceptT {If a (Left Fail) (Right x)} -- -- This will return a symbolic union value representing a program that -- throws an error in the @then@ branch and returns a value in the @else@ -- branch. - -- - -- __The following is the details of the merging algorithm.__ + + -- ** Details of the merging algorithm #merging# + + -- | __The following is the details of the merging algorithm.__ -- __If you are not going to manually configure the system by writing a__ -- __`MergingStrategy` and will only use the derived strategies,__ -- __you can safely ignore the following contents in this section.__ @@ -367,13 +577,13 @@ -- symbolic integers with length 1, 2 or 3. The values are kept sorted in the -- container: the list with length 1 is placed at the first place, the -- list with length 2 is placed at the second place, and so on. - -- + + -- | -- \[ - -- \left\{\begin{aligned} - -- &\texttt{[a]}&&\mathrm{if}&&\texttt{c1}\\ - -- &\texttt{[b,b]}&&\mathrm{else~if}&&\texttt{c2}\\& - -- \texttt{[a,b,c]}&&\mathrm{otherwise} - -- \end{aligned}\right. + -- \left\{\begin{aligned}% + -- &\texttt{[a]}&&\mathrm{if}&&\texttt{c1}\\% + -- &\texttt{[b,b]}&&\mathrm{else~if}&&\texttt{c2}\\% + -- &\texttt{[a,b,c]}&&\mathrm{otherwise}\end{aligned}\right. -- \] -- -- In Haskell syntax, the container is represented as the following nested @@ -391,9 +601,9 @@ -- distribute the 'head' function through the three branches, and get -- -- \[ - -- \left\{\begin{aligned} - -- &\texttt{head [a]}&&\mathrm{if}&&\texttt{c1}\\ - -- &\texttt{head [b,b]}&&\mathrm{else~if}&&\texttt{c2}\\ + -- \left\{\begin{aligned}% + -- &\texttt{head [a]}&&\mathrm{if}&&\texttt{c1}\\% + -- &\texttt{head [b,b]}&&\mathrm{else~if}&&\texttt{c2}\\% -- &\texttt{head [a,b,c]}&&\mathrm{otherwise} -- \end{aligned}\right. -- \] @@ -401,10 +611,10 @@ -- or, equivalently -- -- \[ - -- \left\{\begin{aligned} - -- &\texttt{a}&&\mathrm{if}&&\texttt{c1}\\ - -- &\texttt{b}&&\mathrm{else~if}&&\texttt{c2}\\ - -- &\texttt{a}&&\mathrm{otherwise} + -- \left\{\begin{aligned}% + -- &\texttt{a}&&\mathrm{if}&&\texttt{c1}\\% + -- &\texttt{b}&&\mathrm{else~if}&&\texttt{c2}\\% + -- &\texttt{a}&&\mathrm{otherwise}% -- \end{aligned}\right. -- \] -- @@ -414,9 +624,9 @@ -- the branches, and the previous result would become -- -- \[ - -- \left\{\begin{aligned} - -- &\texttt{a}&&\mathrm{if}&&\texttt{c1}\vee\neg\texttt{c2}\\ - -- &\texttt{b}&&\mathrm{otherwise}\\ + -- \left\{\begin{aligned}% + -- &\texttt{a}&&\mathrm{if}&&\texttt{c1}\vee\neg\texttt{c2}\\% + -- &\texttt{b}&&\mathrm{otherwise}\\% -- \end{aligned}\right. -- \] -- @@ -427,8 +637,9 @@ -- \left\{\begin{aligned}&\texttt{(ite c1 a (ite c2 b a))}&&\mathrm{unconditional}\end{aligned}\right. -- \] -- - -- In Grisette, such merging happens in the `mrgIf` or `unionIf` functions, - -- which model the symbolic conditional branching semantics. + -- In Grisette, such merging happens in the `mrgIf` or + -- `Grisette.Internal.Core.SimpleMergeable.mrgIfPropagatedStrategy` + -- functions, which model the symbolic conditional branching semantics. -- To keep the merging efficient and generate small constraints, we enforce -- that the symbolic union maintains the values in a sorted way, and merge -- the unions with a mergesort-style merging algorithm. In the following @@ -438,24 +649,24 @@ -- maintained. -- -- \[ - -- \texttt{mrgIf}\left[ - -- \texttt{c}, - -- \left\{\begin{aligned} - -- &\texttt{1}&&\mathrm{if}&&\texttt{c1}\\ - -- &\texttt{3}&&\mathrm{else~if}&&\texttt{c2}\\ - -- &\texttt{4}&&\mathrm{otherwise} - -- \end{aligned}\right., - -- \left\{\begin{aligned} - -- &\texttt{1}&&\mathrm{if}&&\texttt{c3}\\ - -- &\texttt{2}&&\mathrm{else~if}&&\texttt{c4}\\ - -- &\texttt{4}&&\mathrm{otherwise} - -- \end{aligned}\right. - -- \right] - -- =\left\{\begin{aligned} - -- &\texttt{1}&&\mathrm{if}&&\texttt{(ite c c1 c3)}\\ - -- &\texttt{2}&&\mathrm{else~if}&&\texttt{(&& (! c) c3)}\\ - -- &\texttt{3}&&\mathrm{else~if}&&\texttt{(&& c c2)}\\ - -- &\texttt{4}&&\mathrm{otherwise} + -- \texttt{mrgIf}\left[% + -- \texttt{c},% + -- \left\{\begin{aligned}% + -- &\texttt{1}&&\mathrm{if}&&\texttt{c1}\\% + -- &\texttt{3}&&\mathrm{else~if}&&\texttt{c2}\\% + -- &\texttt{4}&&\mathrm{otherwise}% + -- \end{aligned}\right.,% + -- \left\{\begin{aligned}% + -- &\texttt{1}&&\mathrm{if}&&\texttt{c3}\\% + -- &\texttt{2}&&\mathrm{else~if}&&\texttt{c4}\\% + -- &\texttt{4}&&\mathrm{otherwise}% + -- \end{aligned}\right.% + -- \right]% + -- =\left\{\begin{aligned}% + -- &\texttt{1}&&\mathrm{if}&&\texttt{(ite c c1 c3)}\\% + -- &\texttt{2}&&\mathrm{else~if}&&\texttt{(&& (! c) c3)}\\% + -- &\texttt{3}&&\mathrm{else~if}&&\texttt{(&& c c2)}\\% + -- &\texttt{4}&&\mathrm{otherwise}% -- \end{aligned}\right. -- \] -- @@ -483,16 +694,16 @@ -- > data X = A Integer SymInteger | B | C -- -- \[ - -- \left\{\begin{aligned} - -- &\texttt{t1}&&\mathrm{if}&&\texttt{c1}\\ - -- &\texttt{B}&&\mathrm{else if}&&\texttt{c2}\\ - -- &\texttt{C}&&\mathrm{otherwise}&& - -- \end{aligned}\right. - -- \hspace{2em}\mathrm{where}\hspace{2em} - -- \texttt{t1} = \left\{\begin{aligned} - -- &\texttt{A 1 a}&&\mathrm{if}&&\texttt{c11}\\ - -- &\texttt{A 3 b}&&\mathrm{else if}&&\texttt{c12}\\ - -- &\texttt{A 4 (&& x y)}&&\mathrm{otherwise}&& + -- \left\{\begin{aligned}% + -- &\texttt{t1}&&\mathrm{if}&&\texttt{c1}\\% + -- &\texttt{B}&&\mathrm{else if}&&\texttt{c2}\\% + -- &\texttt{C}&&\mathrm{otherwise}&&% + -- \end{aligned}\right.% + -- \hspace{2em}\mathrm{where}\hspace{2em}% + -- \texttt{t1} = \left\{\begin{aligned}% + -- &\texttt{A 1 a}&&\mathrm{if}&&\texttt{c11}\\% + -- &\texttt{A 3 b}&&\mathrm{else if}&&\texttt{c12}\\% + -- &\texttt{A 4 (&& x y)}&&\mathrm{otherwise}&&% -- \end{aligned}\right. -- \] -- @@ -531,39 +742,39 @@ -- for 'MergingStrategy' for details. -- -- \[ - -- \begin{aligned} - -- & \texttt{mrgIf}\left[ - -- \texttt{c}, - -- \left\{\begin{aligned} - -- &\texttt{t1}&&\mathrm{if}&&\texttt{c1}\\ - -- &\texttt{v3}&&\mathrm{else~if}&&\texttt{c2}\\ - -- &\texttt{v4}&&\mathrm{otherwise} - -- \end{aligned}\right., - -- \left\{\begin{aligned} - -- &\texttt{t1'}&&\mathrm{if}&&\texttt{c3}\\ - -- &\texttt{t2'}&&\mathrm{else~if}&&\texttt{c4}\\ - -- &\texttt{v4'}&&\mathrm{otherwise} - -- \end{aligned}\right. - -- \right]\\ - -- =~ & \texttt{mrgIf'}\left[ - -- \texttt{s}, - -- \texttt{c}, - -- \left\{\begin{aligned} - -- &\texttt{t1}&&\mathrm{if}&&\texttt{c1}\\ - -- &\texttt{v3}&&\mathrm{else~if}&&\texttt{c2}\\ - -- &\texttt{v4}&&\mathrm{otherwise} - -- \end{aligned}\right., - -- \left\{\begin{aligned} - -- &\texttt{t1'}&&\mathrm{if}&&\texttt{c3}\\ - -- &\texttt{t2'}&&\mathrm{else~if}&&\texttt{c4}\\ - -- &\texttt{v4'}&&\mathrm{otherwise} - -- \end{aligned}\right. - -- \right]\\ - -- =~ & \left\{\begin{aligned} - -- &\texttt{mrgIf' s' c t1 t1'}&&\mathrm{if}&&\texttt{(ite c c1 c3)}\\ - -- &\texttt{t2'}&&\mathrm{else~if}&&\texttt{(&& (! c) c4)}\\ - -- &\texttt{v3}&&\mathrm{else~if}&&\texttt{(&& c c2)}\\ - -- &\texttt{f' c v4 v4'}&&\mathrm{otherwise} + -- \begin{aligned}% + -- & \texttt{mrgIf}\left[% + -- \texttt{c},% + -- \left\{\begin{aligned}% + -- &\texttt{t1}&&\mathrm{if}&&\texttt{c1}\\% + -- &\texttt{v3}&&\mathrm{else~if}&&\texttt{c2}\\% + -- &\texttt{v4}&&\mathrm{otherwise}% + -- \end{aligned}\right.,% + -- \left\{\begin{aligned}% + -- &\texttt{t1'}&&\mathrm{if}&&\texttt{c3}\\% + -- &\texttt{t2'}&&\mathrm{else~if}&&\texttt{c4}\\% + -- &\texttt{v4'}&&\mathrm{otherwise}% + -- \end{aligned}\right.% + -- \right]\\% + -- =~ & \texttt{mrgIf'}\left[% + -- \texttt{s},% + -- \texttt{c},% + -- \left\{\begin{aligned}% + -- &\texttt{t1}&&\mathrm{if}&&\texttt{c1}\\% + -- &\texttt{v3}&&\mathrm{else~if}&&\texttt{c2}\\% + -- &\texttt{v4}&&\mathrm{otherwise}% + -- \end{aligned}\right.,% + -- \left\{\begin{aligned}% + -- &\texttt{t1'}&&\mathrm{if}&&\texttt{c3}\\% + -- &\texttt{t2'}&&\mathrm{else~if}&&\texttt{c4}\\% + -- &\texttt{v4'}&&\mathrm{otherwise}% + -- \end{aligned}\right.% + -- \right]\\% + -- =~ & \left\{\begin{aligned}% + -- &\texttt{mrgIf' s' c t1 t1'}&&\mathrm{if}&&\texttt{(ite c c1 c3)}\\% + -- &\texttt{t2'}&&\mathrm{else~if}&&\texttt{(&& (! c) c4)}\\% + -- &\texttt{v3}&&\mathrm{else~if}&&\texttt{(&& c c2)}\\% + -- &\texttt{f' c v4 v4'}&&\mathrm{otherwise}% -- \end{aligned}\right. -- \end{aligned} -- \] @@ -571,18 +782,17 @@ -- For more details of the algorithm, please refer to -- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf). - -- *** UnionM Monad - UnionM, + -- ** Union Monad + Union, IsConcrete, - unionMUnaryOp, - unionMBinOp, - liftUnionM, + unionUnaryOp, + unionBinOp, + liftUnion, + unionMergingStrategy, liftToMonadUnion, unionSize, - -- *** Merging - - -- **** Mergeable + -- ** Mergeable Mergeable (..), Mergeable1 (..), rootStrategy1, @@ -591,11 +801,10 @@ Mergeable3 (..), rootStrategy3, - -- **** Merging strategy + -- ** Merging strategy MergingStrategy (..), - derivedRootStrategy, - -- **** Manual merging strategy construction + -- ** Manual merging strategy construction wrapStrategy, product2Strategy, DynamicSortedIdx (..), @@ -604,25 +813,27 @@ resolveStrategy, resolveStrategy', - -- **** Simple mergeable types + -- ** Simple mergeable types SimpleMergeable (..), SimpleMergeable1 (..), mrgIte1, SimpleMergeable2 (..), mrgIte2, - UnionMergeable1 (..), + + -- ** Symbolic branching + SymBranching (..), mrgIf, mergeWithStrategy, merge, - -- **** TryMerge operations + -- ** TryMerge operations MonadTryMerge, TryMerge (..), mrgSingle, mrgSingleWithStrategy, tryMerge, - -- **** PlainUnion operations + -- ** PlainUnion operations PlainUnion (..), pattern Single, pattern If, @@ -634,13 +845,32 @@ onUnion4, MonadUnion, - -- * Conversion between Concrete and Symbolic values - ToCon (..), - ToSym (..), - -- * Pretty printing - GPretty (..), + PPrint (..), + docToTextWith, + docToTextWithWidth, + docToText, + pformatTextWith, + pformatTextWithWidth, + pformatText, + pprint, + PPrint1 (..), + pformatPrec1, + pformatList1, + PPrint2 (..), + pformatPrec2, + pformatList2, + -- ** Helpers for pretty printing + groupedEnclose, + condEnclose, + pformatWithConstructor, + pformatWithConstructorNoAlign, + viaShowsPrec, + + -- ** Re-export Prettyprinter for convenience + module Prettyprinter, + -- * Symbolic Generation -- | It is usually useful to generate complex symbolic values. For example, @@ -685,7 +915,7 @@ -- We can generate a list of length 0, 1, or 2 by specifying the minimum -- and maximum lengths, and the specification for the elements: -- - -- >>> runFresh (fresh (ListSpec 0 2 ())) "x" :: UnionM [SymBool] + -- >>> runFresh (fresh (ListSpec 0 2 ())) "x" :: Union [SymBool] -- {If x@2 [] (If x@3 [x@1] [x@0,x@1])} -- -- We can generate many symbolic values at once with the 'Fresh' monad. @@ -695,7 +925,7 @@ -- >>> :{ -- flip runFresh "x" $ do -- a :: SymBool <- simpleFresh () - -- b :: UnionM [SymBool] <- fresh (ListSpec 0 2 ()) + -- b :: Union [SymBool] <- fresh (ListSpec 0 2 ()) -- return (a, b) -- :} -- (x@0,{If x@3 [] (If x@4 [x@2] [x@1,x@2])}) @@ -706,7 +936,7 @@ -- -- >>> genSymSimple (SimpleListSpec 2 ()) "x" :: [SymBool] -- [x@0,x@1] - -- >>> genSym (ListSpec 0 2 ()) "x" :: UnionM [SymBool] + -- >>> genSym (ListSpec 0 2 ()) "x" :: Union [SymBool] -- {If x@2 [] (If x@3 [x@1] [x@0,x@1])} -- -- Symbolic choices from a list of symbolic values is very useful. @@ -720,7 +950,7 @@ -- (flip runFresh "x" $ do -- a <- simpleFresh () -- b <- simpleFresh () - -- chooseFresh [[a],[a,b],[a,a,b]]) :: UnionM [SymBool] + -- chooseFresh [[a],[a,b],[a,a,b]]) :: Union [SymBool] -- :} -- {If x@2 [x@0] (If x@3 [x@0,x@1] [x@0,x@0,x@1])} @@ -763,7 +993,7 @@ ListSpec (..), SimpleListSpec (..), - -- * Error Handling + -- * Error Handling #errors# -- | -- Grisette supports using 'Control.Monad.Except.ExceptT' to handle errors, @@ -772,7 +1002,7 @@ -- -- >>> import Control.Monad.Except -- >>> import Grisette.Lib.Control.Monad.Except - -- >>> mrgThrowError AssertionError :: ExceptT AssertionError UnionM () + -- >>> mrgThrowError AssertionError :: ExceptT AssertionError Union () -- ExceptT {Left AssertionError} -- -- You can define your own error types, and reason about them with the @@ -788,16 +1018,16 @@ -- :} -- -- >>> let [a,b,c] = ["a","b","c"] :: [SymBool] - -- >>> res = mrgIf a (throwError Error1) (mrgIf b (return c) (throwError Error2)) :: ExceptT Error UnionM SymBool + -- >>> res = mrgIf a (throwError Error1) (mrgIf b (return c) (throwError Error2)) :: ExceptT Error Union SymBool -- >>> res -- ExceptT {If (|| a (! b)) (If a (Left Error1) (Left Error2)) (Right c)} - -- >>> solveExcept (precise z3) (\case Left _ -> con False; Right x -> x) res + -- >>> solveExcept z3 (\case Left _ -> con False; Right x -> x) res -- Right (Model {a -> False :: Bool, b -> True :: Bool, c -> True :: Bool}) -- -- The solver call in the above example means that we want the solver to -- find the conditions under which no error is thrown, and the result is -- true. For more details, please refer to the - -- [documentation of the solver APIs](#solver). + -- [documentation of the solver APIs](#g:solver). -- -- For those who prefer to encode errors as assertions and assumptions, -- we provide the 'symAssert' and 'symAssume' functions. These functions @@ -805,8 +1035,6 @@ -- and assumptions to the user-defined error type. -- See their documentation for details. - -- | #errors# - -- ** Predefined errors AssertionError (..), VerificationConditions (..), @@ -826,9 +1054,7 @@ mapCBMCExceptT, withCBMCExceptT, - -- * Solver backend - - -- | #solver# + -- * Solver backend #solver# -- | Grisette abstracts the solver backend with the 'Solver' type class, -- and the most basic solver call is the 'solve' function. @@ -861,16 +1087,16 @@ -- >>> import Grisette.Backend -- >>> let x = "x" :: SymInteger -- >>> let y = "y" :: SymInteger - -- >>> solve (precise z3) (x + y .== 6 .&& x - y .== 20) + -- >>> solve z3 (x + y .== 6 .&& x - y .== 20) -- Right (Model {x -> 13 :: Integer, y -> -7 :: Integer}) - -- >>> solve (precise z3) (x + y .== 6 .&& x - y .== 19) + -- >>> solve z3 (x + y .== 6 .&& x - y .== 19) -- Left Unsat -- - -- The first parameter of 'solve' is the solver configuration. - -- Here it means that we should not perform any approximation, and should - -- use the Z3 solver. + -- The first parameter of 'solve' is the solver configuration. Here we are + -- using the configuration for the Z3 solver. -- - -- The second parameter is the formula to be solved. It have the type 'SymBool'. + -- The second parameter is the formula to be solved. It has the type + -- 'SymBool'. -- -- The 'solve' function would return a model if the formula is satisfiable. -- The model is a mapping from symbolic variables to concrete values, @@ -882,11 +1108,11 @@ -- evaluate symbolic values. The following code evaluates the product of -- x and y under the solution of the equation system. -- - -- >>> Right m <- solve (precise z3) (x + y .== 6 .&& x - y .== 20) - -- >>> evaluateSym False m (x * y) + -- >>> Right m <- solve z3 (x + y .== 6 .&& x - y .== 20) + -- >>> evalSym False m (x * y) -- -91 -- - -- You may notice that the first argument to the 'evaluateSym' function is + -- You may notice that the first argument to the 'evalSym' function is -- a Boolean value 'False'. This argument controls whether the evaluation -- should assign a default value to the symbolic constants that does not -- appear in the model. When the argument is 'False', the evaluation would @@ -897,9 +1123,9 @@ -- result would become a concrete value -91. -- -- >>> let z = "z" :: SymInteger - -- >>> evaluateSym False m (x * y + z) + -- >>> evalSym False m (x * y + z) -- (+ -91 z) - -- >>> evaluateSym True m (x * y + z) + -- >>> evalSym True m (x * y + z) -- -91 -- -- Grisette also provides convenient functions to solve problems with error @@ -922,7 +1148,7 @@ -- >>> :{ -- data Error = Arith | Assert -- deriving (Show, Generic) - -- deriving (Mergeable, SEq) via (Default Error) + -- deriving (Mergeable, SymEq) via (Default Error) -- :} -- -- Then we can perform the symbolic evaluation. The `divs` function throws @@ -932,13 +1158,13 @@ -- -- >>> let x = "x" :: SymInteger -- >>> let y = "y" :: SymInteger - -- >>> assert = symAssertWith Assert + -- >>> assert = symAssertWith Assert :: SymBool -> ExceptT Error Union () -- >>> sdiv l r = mrgWithExceptT (\(_::ArithException) -> Arith) $ safeDiv l r -- >>> :{ -- -- equivalent concrete program: -- -- let x = x `div` y -- -- if z > 0 then assert (x >= y) else return () - -- res :: ExceptT Error UnionM () + -- res :: ExceptT Error Union () -- res = do -- z <- x `sdiv` y -- mrgIf (z .> 0) (assert (x .>= y)) (return ()) @@ -1019,6 +1245,8 @@ cegisForAllExceptStdVC, cegisForAllExceptVC, + -- * Substitutions for symbolic values given solver models + -- ** Symbolic constant extraction -- Grisette supports the extraction of the symbolic constant symbols from a @@ -1026,7 +1254,11 @@ -- the solver. The builtin CEGIS procedure relies on this. SymbolSetOps (..), SymbolSetRep (..), - ExtractSymbolics (..), + ExtractSym (..), + ExtractSym1 (..), + extractSym1, + ExtractSym2 (..), + extractSym2, -- ** Evaluation with a model @@ -1037,18 +1269,23 @@ -- the symbolic constants with the concrete assignments. ModelOps (..), ModelRep (..), - EvaluateSym (..), - evaluateSymToCon, + EvalSym (..), + evalSymToCon, + EvalSym1 (..), + evalSym1, + evalSymToCon1, + EvalSym2 (..), + evalSym2, + evalSymToCon2, -- ** Substitution of a symbol - SubstituteSym (..), - SubstituteSym' (..), - - -- * Type Class Derivation - Default (..), - Default1 (..), + SubstSym (..), + SubstSym1 (..), + substSym1, + SubstSym2 (..), + substSym2, - -- * Utilities + -- * Utilities #utils# -- ** Memoization htmemo, @@ -1057,9 +1294,74 @@ htmup, htmemoFix, - -- ** Template Haskell - mkMergeConstructor, - mkMergeConstructor', + -- ** Generic deriving of classes + + -- *** Default wrappers + Default (..), + Default1 (..), + + -- *** 'SymEq' + SymEqArgs (..), + GSymEq (..), + genericSymEq, + genericLiftSymEq, + + -- *** 'SymOrd' + SymOrdArgs (..), + GSymOrd (..), + genericSymCompare, + genericLiftSymCompare, + + -- *** 'Mergeable' + MergeableArgs (..), + GMergeable (..), + genericRootStrategy, + genericLiftRootStrategy, + + -- *** 'SimpleMergeable' + SimpleMergeableArgs (..), + GSimpleMergeable (..), + genericMrgIte, + genericLiftMrgIte, + + -- *** 'ToCon' + ToConArgs (..), + GToCon (..), + genericToCon, + genericLiftToCon, + + -- *** 'ToSym' + ToSymArgs (..), + GToSym (..), + genericToSym, + genericLiftToSym, + + -- *** 'EvalSym' + EvalSymArgs (..), + GEvalSym (..), + genericEvalSym, + genericLiftEvalSym, + + -- *** 'ExtractSym' + ExtractSymArgs (..), + GExtractSym (..), + genericExtractSym, + genericLiftExtractSym, + + -- *** 'SubstSym' + SubstSymArgs (..), + GSubstSym (..), + genericSubstSym, + genericLiftSubstSym, + + -- *** 'PPrint' + genericPFormatPrec, + genericLiftPFormatPrec, + genericPFormatList, + genericLiftPFormatList, + PPrintArgs (..), + GPPrint (..), + PPrintType (..), ) where @@ -1075,16 +1377,18 @@ mapCBMCExceptT, withCBMCExceptT, ) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) -import Grisette.Internal.Core.Control.Monad.UnionM +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Union ( IsConcrete, - UnionM, + Union, liftToMonadUnion, - liftUnionM, - unionMBinOp, - unionMUnaryOp, + liftUnion, + unionBinOp, + unionMergingStrategy, unionSize, + unionUnaryOp, ) +import Grisette.Internal.Core.Data.Class.BitCast (BitCast (..)) import Grisette.Internal.Core.Data.Class.BitVector ( BV (..), SizedBV (..), @@ -1136,15 +1440,32 @@ symAssume, symThrowTransformableError, ) -import Grisette.Internal.Core.Data.Class.EvaluateSym - ( EvaluateSym (..), - evaluateSymToCon, +import Grisette.Internal.Core.Data.Class.EvalSym + ( EvalSym (..), + EvalSym1 (..), + EvalSym2 (..), + EvalSymArgs (..), + GEvalSym (..), + evalSym1, + evalSym2, + evalSymToCon, + evalSymToCon1, + evalSymToCon2, + genericEvalSym, + genericLiftEvalSym, ) -import Grisette.Internal.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (..), +import Grisette.Internal.Core.Data.Class.ExtractSym + ( ExtractSym (..), + ExtractSym1 (..), + ExtractSym2 (..), + ExtractSymArgs (..), + GExtractSym (..), + extractSym1, + extractSym2, + genericExtractSym, + genericLiftExtractSym, ) import Grisette.Internal.Core.Data.Class.Function (Apply (..), Function (..)) -import Grisette.Internal.Core.Data.Class.GPretty (GPretty (..)) import Grisette.Internal.Core.Data.Class.GenSym ( EnumGenBound (..), EnumGenUpperBound (..), @@ -1174,18 +1495,40 @@ runFresh, runFreshT, ) +import Grisette.Internal.Core.Data.Class.IEEEFP + ( IEEEConstants (..), + IEEEFPOp (..), + IEEEFPRoundingMode (..), + IEEEFPRoundingOp (..), + SymIEEEFPTraits (..), + fpIsInfinite, + fpIsNaN, + fpIsNegative, + fpIsNegativeInfinite, + fpIsNegativeZero, + fpIsNormal, + fpIsPoint, + fpIsPositive, + fpIsPositiveInfinite, + fpIsPositiveZero, + fpIsSubnormal, + fpIsZero, + ) import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (..)) import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (..)) import Grisette.Internal.Core.Data.Class.Mergeable ( DynamicSortedIdx (..), + GMergeable (..), Mergeable (..), Mergeable1 (..), Mergeable2 (..), Mergeable3 (..), + MergeableArgs (..), MergingStrategy (..), StrategyList (..), buildStrategyList, - derivedRootStrategy, + genericLiftRootStrategy, + genericRootStrategy, product2Strategy, resolveStrategy, resolveStrategy', @@ -1200,6 +1543,34 @@ SymbolSetOps (..), SymbolSetRep (..), ) +import Grisette.Internal.Core.Data.Class.PPrint + ( GPPrint (..), + PPrint (..), + PPrint1 (..), + PPrint2 (..), + PPrintArgs (..), + PPrintType (..), + condEnclose, + docToText, + docToTextWith, + docToTextWithWidth, + genericLiftPFormatList, + genericLiftPFormatPrec, + genericPFormatList, + genericPFormatPrec, + groupedEnclose, + pformatList1, + pformatList2, + pformatPrec1, + pformatPrec2, + pformatText, + pformatTextWith, + pformatTextWithWidth, + pformatWithConstructor, + pformatWithConstructorNoAlign, + pprint, + viaShowsPrec, + ) import Grisette.Internal.Core.Data.Class.PlainUnion ( PlainUnion (..), onUnion, @@ -1211,24 +1582,20 @@ pattern If, pattern Single, ) -import Grisette.Internal.Core.Data.Class.SEq (SEq (..)) -import Grisette.Internal.Core.Data.Class.SOrd - ( SOrd (..), - mrgMax, - mrgMin, - symMax, - symMin, - ) import Grisette.Internal.Core.Data.Class.SafeDivision (SafeDivision (..)) import Grisette.Internal.Core.Data.Class.SafeLinearArith (SafeLinearArith (..)) import Grisette.Internal.Core.Data.Class.SafeSymRotate (SafeSymRotate (..)) import Grisette.Internal.Core.Data.Class.SafeSymShift (SafeSymShift (..)) import Grisette.Internal.Core.Data.Class.SignConversion (SignConversion (..)) import Grisette.Internal.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (..), + ( GSimpleMergeable (..), + SimpleMergeable (..), SimpleMergeable1 (..), SimpleMergeable2 (..), - UnionMergeable1 (..), + SimpleMergeableArgs (..), + SymBranching (..), + genericLiftMrgIte, + genericMrgIte, merge, mergeWithStrategy, mrgIf, @@ -1259,14 +1626,67 @@ solverSolveMultiExcept, withSolver, ) -import Grisette.Internal.Core.Data.Class.SubstituteSym - ( SubstituteSym (..), - SubstituteSym' (..), +import Grisette.Internal.Core.Data.Class.SubstSym + ( GSubstSym (..), + SubstSym (..), + SubstSym1 (..), + SubstSym2 (..), + SubstSymArgs (..), + genericLiftSubstSym, + genericSubstSym, + substSym1, + substSym2, ) +import Grisette.Internal.Core.Data.Class.SymEq + ( GSymEq (..), + SymEq (..), + SymEq1 (..), + SymEq2 (..), + SymEqArgs (..), + genericLiftSymEq, + genericSymEq, + symEq1, + symEq2, + ) +import Grisette.Internal.Core.Data.Class.SymOrd + ( GSymOrd (..), + SymOrd (..), + SymOrd1 (..), + SymOrd2 (..), + SymOrdArgs (..), + genericLiftSymCompare, + genericSymCompare, + mrgMax, + mrgMin, + symCompare1, + symCompare2, + symMax, + symMin, + ) import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate (..)) import Grisette.Internal.Core.Data.Class.SymShift (SymShift (..)) -import Grisette.Internal.Core.Data.Class.ToCon (ToCon (..)) -import Grisette.Internal.Core.Data.Class.ToSym (ToSym (..)) +import Grisette.Internal.Core.Data.Class.ToCon + ( GToCon (..), + ToCon (..), + ToCon1 (..), + ToCon2 (..), + ToConArgs (..), + genericLiftToCon, + genericToCon, + toCon1, + toCon2, + ) +import Grisette.Internal.Core.Data.Class.ToSym + ( GToSym (..), + ToSym (..), + ToSym1 (..), + ToSym2 (..), + ToSymArgs (..), + genericLiftToSym, + genericToSym, + toSym1, + toSym2, + ) import Grisette.Internal.Core.Data.Class.TryMerge ( MonadTryMerge, TryMerge (..), @@ -1291,18 +1711,35 @@ withInfo, withLoc, ) -import Grisette.Internal.Core.TH.MergeConstructor - ( mkMergeConstructor, - mkMergeConstructor', - ) +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter +#else +import Data.Text.Prettyprint.Doc as Prettyprinter +#endif -- $setup -- >>> import Grisette.Core -- >>> import Grisette.Lib.Base -- >>> import Grisette.SymPrim +-- >>> import Grisette.TH -- >>> :set -XDataKinds -- >>> :set -XBinaryLiterals -- >>> :set -XFlexibleContexts -- >>> :set -XFlexibleInstances -- >>> :set -XFunctionalDependencies -- >>> :set -XOverloadedStrings +-- >>> :set -XTemplateHaskell +-- >>> :set -XScopedTypeVariables +-- >>> :set -XDerivingVia +-- >>> :set -XStandaloneDeriving +-- >>> :set -XTypeApplications +-- >>> :set -XFlexibleInstances +-- >>> :set -XMultiParamTypeClasses +-- >>> :set -XFlexibleContexts +-- >>> :set -XDeriveLift +-- >>> :set -XUndecidableInstances +-- >>> :set -XDeriveAnyClass +-- >>> :set -XMonoLocalBinds +-- >>> :set -XDerivingStrategies +-- >>> :set -XDerivingVia +-- >>> :set -XDeriveGeneric diff --git a/src/Grisette/Experimental.hs b/src/Grisette/Experimental.hs --- a/src/Grisette/Experimental.hs +++ b/src/Grisette/Experimental.hs @@ -19,18 +19,18 @@ derivedFreshConstrainedNoSpec, -- ** Some common GenSymConstrained specifications - SOrdUpperBound (..), - SOrdLowerBound (..), - SOrdBound (..), + SymOrdUpperBound (..), + SymOrdLowerBound (..), + SymOrdBound (..), ) where import Grisette.Experimental.GenSymConstrained ( GenSymConstrained (..), GenSymSimpleConstrained (..), - SOrdBound (..), - SOrdLowerBound (..), - SOrdUpperBound (..), + SymOrdBound (..), + SymOrdLowerBound (..), + SymOrdUpperBound (..), derivedFreshConstrainedNoSpec, derivedSimpleFreshConstrainedNoSpec, derivedSimpleFreshConstrainedSameShape, diff --git a/src/Grisette/Experimental/GenSymConstrained.hs b/src/Grisette/Experimental/GenSymConstrained.hs --- a/src/Grisette/Experimental/GenSymConstrained.hs +++ b/src/Grisette/Experimental/GenSymConstrained.hs @@ -30,9 +30,9 @@ derivedSimpleFreshConstrainedSameShape, -- * Some common GenSymConstrained specifications - SOrdUpperBound (..), - SOrdLowerBound (..), - SOrdBound (..), + SymOrdUpperBound (..), + SymOrdLowerBound (..), + SymOrdBound (..), ) where @@ -46,9 +46,9 @@ type (:*:) ((:*:)), type (:+:) (L1, R1), ) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) -import Grisette.Internal.Core.Control.Monad.UnionM - ( UnionM, +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Union + ( Union, liftToMonadUnion, ) import Grisette.Internal.Core.Data.Class.GenSym @@ -63,10 +63,10 @@ ) import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.||))) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1) -import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<), (.>=))) import Grisette.Internal.Core.Data.Class.SimpleMergeable ( mrgIf, ) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd ((.<), (.>=))) import Grisette.Internal.Core.Data.Class.TryMerge ( mrgSingle, tryMerge, @@ -90,13 +90,13 @@ -- -- Constraint violations will throw an error in the monadic environment. -- - -- >>> runFreshT (freshConstrained () (SOrdUpperBound (1 :: SymInteger) ())) "a" :: ExceptT () UnionM (UnionM SymInteger) + -- >>> runFreshT (freshConstrained () (SymOrdUpperBound (1 :: SymInteger) ())) "a" :: ExceptT () Union (Union SymInteger) -- ExceptT freshConstrained :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> spec -> - m (UnionM a) + m (Union a) default freshConstrained :: (GenSymSimpleConstrained spec a) => ( MonadFresh m, @@ -105,10 +105,10 @@ ) => e -> spec -> - m (UnionM a) + m (Union a) freshConstrained e spec = mrgSingle <$> simpleFreshConstrained e spec -genSymConstrained :: forall spec a e. (GenSymConstrained spec a, Mergeable e) => e -> spec -> Identifier -> ExceptT e UnionM (UnionM a) +genSymConstrained :: forall spec a e. (GenSymConstrained spec a, Mergeable e) => e -> spec -> Identifier -> ExceptT e Union (Union a) genSymConstrained e spec = tryMerge . runFreshT (freshConstrained e spec) -- | Class of types in which symbolic values can be generated with some @@ -121,7 +121,7 @@ -- -- Constraint violations will throw an error in the monadic environment. -- - -- >>> runFreshT (simpleFreshConstrained () (SOrdUpperBound (1 :: SymInteger) ())) "a" :: ExceptT () UnionM SymInteger + -- >>> runFreshT (simpleFreshConstrained () (SymOrdUpperBound (1 :: SymInteger) ())) "a" :: ExceptT () Union SymInteger -- ExceptT simpleFreshConstrained :: (MonadFresh m, MonadError e m, MonadUnion m) => @@ -129,7 +129,7 @@ spec -> m a -genSymSimpleConstrained :: forall spec a e. (GenSymSimpleConstrained spec a, Mergeable e) => e -> spec -> Identifier -> ExceptT e UnionM a +genSymSimpleConstrained :: forall spec a e. (GenSymSimpleConstrained spec a, Mergeable e) => e -> spec -> Identifier -> ExceptT e Union a genSymSimpleConstrained e spec = tryMerge . runFreshT (simpleFreshConstrained e spec) instance {-# OVERLAPPABLE #-} (Mergeable a, GenSym spec a) => GenSymConstrained spec a where @@ -140,57 +140,57 @@ -- | Exclusive bound, generates the values with the specification, then filters -- out the ones that are greater than or equal to the bound -data SOrdUpperBound a spec = SOrdUpperBound a spec +data SymOrdUpperBound a spec = SymOrdUpperBound a spec -instance {-# OVERLAPPABLE #-} (SOrd a, Mergeable a, GenSym spec a) => GenSymConstrained (SOrdUpperBound a spec) a where - freshConstrained e (SOrdUpperBound u spec) = do +instance {-# OVERLAPPABLE #-} (SymOrd a, Mergeable a, GenSym spec a) => GenSymConstrained (SymOrdUpperBound a spec) a where + freshConstrained e (SymOrdUpperBound u spec) = do s <- fresh spec v <- liftToMonadUnion s mrgIf (v .>= u) (throwError e) (return ()) mrgSingle $ mrgSingle v -instance {-# OVERLAPPABLE #-} (SOrd a, Mergeable a, GenSymSimple spec a) => GenSymSimpleConstrained (SOrdUpperBound a spec) a where - simpleFreshConstrained e (SOrdUpperBound u spec) = do +instance {-# OVERLAPPABLE #-} (SymOrd a, Mergeable a, GenSymSimple spec a) => GenSymSimpleConstrained (SymOrdUpperBound a spec) a where + simpleFreshConstrained e (SymOrdUpperBound u spec) = do s <- simpleFresh spec mrgIf (s .>= u) (throwError e) (return ()) mrgSingle s -- | Inclusive bound, generates the values with the specification, then filters -- out the ones that are less than the bound -data SOrdLowerBound a spec = SOrdLowerBound a spec +data SymOrdLowerBound a spec = SymOrdLowerBound a spec -instance {-# OVERLAPPABLE #-} (SOrd a, Mergeable a, GenSym spec a) => GenSymConstrained (SOrdLowerBound a spec) a where - freshConstrained e (SOrdLowerBound l spec) = do +instance {-# OVERLAPPABLE #-} (SymOrd a, Mergeable a, GenSym spec a) => GenSymConstrained (SymOrdLowerBound a spec) a where + freshConstrained e (SymOrdLowerBound l spec) = do s <- fresh spec v <- liftToMonadUnion s mrgIf (v .< l) (throwError e) (return ()) mrgSingle $ mrgSingle v -instance {-# OVERLAPPABLE #-} (SOrd a, Mergeable a, GenSymSimple spec a) => GenSymSimpleConstrained (SOrdLowerBound a spec) a where - simpleFreshConstrained e (SOrdLowerBound l spec) = do +instance {-# OVERLAPPABLE #-} (SymOrd a, Mergeable a, GenSymSimple spec a) => GenSymSimpleConstrained (SymOrdLowerBound a spec) a where + simpleFreshConstrained e (SymOrdLowerBound l spec) = do s <- simpleFresh spec mrgIf (s .< l) (throwError e) (return ()) mrgSingle s -- | Left-inclusive, right-exclusive bound, generates the values with the -- specification, then filters out the ones that are out-of-bound -data SOrdBound a spec = SOrdBound a a spec +data SymOrdBound a spec = SymOrdBound a a spec -instance {-# OVERLAPPABLE #-} (SOrd a, Mergeable a, GenSym spec a) => GenSymConstrained (SOrdBound a spec) a where - freshConstrained e (SOrdBound l u spec) = do +instance {-# OVERLAPPABLE #-} (SymOrd a, Mergeable a, GenSym spec a) => GenSymConstrained (SymOrdBound a spec) a where + freshConstrained e (SymOrdBound l u spec) = do s <- fresh spec v <- liftToMonadUnion s mrgIf (v .< l .|| v .>= u) (throwError e) (return ()) mrgSingle $ mrgSingle v -instance {-# OVERLAPPABLE #-} (SOrd a, Mergeable a, GenSymSimple spec a) => GenSymSimpleConstrained (SOrdBound a spec) a where - simpleFreshConstrained e (SOrdBound l u spec) = do +instance {-# OVERLAPPABLE #-} (SymOrd a, Mergeable a, GenSymSimple spec a) => GenSymSimpleConstrained (SymOrdBound a spec) a where + simpleFreshConstrained e (SymOrdBound l u spec) = do s <- simpleFresh spec mrgIf (s .< l .|| s .>= u) (throwError e) (return ()) mrgSingle s -instance GenSymConstrained (SOrdBound Integer ()) Integer where - freshConstrained _ (SOrdBound l r _) = chooseFresh [l .. r - 1] +instance GenSymConstrained (SymOrdBound Integer ()) Integer where + freshConstrained _ (SymOrdBound l r _) = chooseFresh [l .. r - 1] -- Either instance @@ -235,7 +235,7 @@ instance (GenSymConstrained aspec a, Mergeable a) => GenSymConstrained aspec (Maybe a) where freshConstrained e aspec = do - a :: UnionM a <- freshConstrained e aspec + a :: Union a <- freshConstrained e aspec tryMerge $ chooseUnionFresh [return Nothing, Just <$> a] -- List @@ -248,7 +248,7 @@ let xs = reverse $ scanr (:) [] l tryMerge $ chooseUnionFresh $ tryMerge . sequence <$> xs where - gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Integer -> m [UnionM a] + gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Integer -> m [Union a] gl e1 v1 | v1 <= 0 = mrgSingle [] | otherwise = do @@ -268,7 +268,7 @@ let xs = drop minLen $ reverse $ scanr (:) [] l tryMerge $ chooseUnionFresh $ tryMerge . sequence <$> xs where - gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Int -> m [UnionM a] + gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Int -> m [Union a] gl e1 currLen | currLen <= 0 = return [] | otherwise = do @@ -281,7 +281,7 @@ GenSymConstrained [a] [a] where freshConstrained e l = do - r :: [UnionM a] <- traverse (freshConstrained e) l + r :: [Union a] <- traverse (freshConstrained e) l mrgSingle $ tryMerge $ sequence r instance @@ -300,7 +300,7 @@ else do tryMerge $ tryMerge . sequence <$> gl e len where - gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Int -> m [UnionM a] + gl :: (MonadFresh m, MonadError e m, MonadUnion m) => e -> Int -> m [Union a] gl e1 currLen | currLen <= 0 = mrgSingle [] | otherwise = do @@ -750,7 +750,7 @@ MonadUnion m ) => e -> - m (UnionM (a c)) + m (Union (a c)) instance GenSymConstrainedNoSpec U1 where freshConstrainedNoSpec _ = return $ mrgSingle U1 @@ -776,11 +776,11 @@ MonadUnion m ) => e -> - m (UnionM ((a :+: b) c)) + m (Union ((a :+: b) c)) freshConstrainedNoSpec e = do cond :: bool <- simpleFresh () - l :: UnionM (a c) <- freshConstrainedNoSpec e - r :: UnionM (b c) <- freshConstrainedNoSpec e + l :: Union (a c) <- freshConstrainedNoSpec e + r :: Union (b c) <- freshConstrainedNoSpec e return $ mrgIf cond (fmap L1 l) (fmap R1 r) instance @@ -794,10 +794,10 @@ MonadUnion m ) => e -> - m (UnionM ((a :*: b) c)) + m (Union ((a :*: b) c)) freshConstrainedNoSpec e = do - l :: UnionM (a c) <- freshConstrainedNoSpec e - r :: UnionM (b c) <- freshConstrainedNoSpec e + l :: Union (a c) <- freshConstrainedNoSpec e + r :: Union (b c) <- freshConstrainedNoSpec e return $ do l1 <- l r1 <- r @@ -822,7 +822,7 @@ ) => e -> () -> - m (UnionM a) + m (Union a) derivedFreshConstrainedNoSpec e _ = tryMerge $ (tryMerge . fmap to) <$> freshConstrainedNoSpec e class GenSymSimpleConstrainedNoSpec a where diff --git a/src/Grisette/Experimental/MonadParallelUnion.hs b/src/Grisette/Experimental/MonadParallelUnion.hs --- a/src/Grisette/Experimental/MonadParallelUnion.hs +++ b/src/Grisette/Experimental/MonadParallelUnion.hs @@ -25,12 +25,12 @@ import qualified Control.Monad.Writer.Lazy as WriterLazy import qualified Control.Monad.Writer.Strict as WriterStrict import Control.Parallel.Strategies (rpar, rseq, runEval) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, underlyingUnion) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Union (Union, unionBase) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf) import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) -import Grisette.Internal.Core.Data.Union (Union (UnionIf, UnionSingle)) +import Grisette.Internal.Core.Data.UnionBase (UnionBase (UnionIf, UnionSingle)) -- | Parallel union monad. -- @@ -41,7 +41,7 @@ -- > import Grisette -- > import qualified Grisette.Qualified.ParallelUnionDo as P -- > P.do --- > x <- mrgIf "a" (return 1) (return 2) :: UnionM Int +-- > x <- mrgIf "a" (return 1) (return 2) :: Union Int -- > return $ x + 1 -- > -- > -- {If a 2 3} @@ -125,11 +125,11 @@ ~(b, s'', w') -> return (b, s'', w <> w') {-# INLINE parBindUnion #-} -parBindUnion'' :: (Mergeable b, NFData b) => Union a -> (a -> UnionM b) -> UnionM b +parBindUnion'' :: (Mergeable b, NFData b) => UnionBase a -> (a -> Union b) -> Union b parBindUnion'' (UnionSingle a) f = tryMerge $ f a parBindUnion'' u f = parBindUnion' u f -parBindUnion' :: (Mergeable b, NFData b) => Union a -> (a -> UnionM b) -> UnionM b +parBindUnion' :: (Mergeable b, NFData b) => UnionBase a -> (a -> Union b) -> Union b parBindUnion' (UnionSingle a') f' = f' a' parBindUnion' (UnionIf _ _ cond ifTrue ifFalse) f' = runEval $ do l <- rpar $ force $ parBindUnion' ifTrue f' @@ -139,6 +139,6 @@ rseq $ mrgIf cond l' r' {-# INLINE parBindUnion' #-} -instance MonadParallelUnion UnionM where - parBindUnion = parBindUnion'' . underlyingUnion +instance MonadParallelUnion Union where + parBindUnion = parBindUnion'' . unionBase {-# INLINE parBindUnion #-} diff --git a/src/Grisette/Internal/Backend/Solving.hs b/src/Grisette/Internal/Backend/Solving.hs --- a/src/Grisette/Internal/Backend/Solving.hs +++ b/src/Grisette/Internal/Backend/Solving.hs @@ -14,7 +14,7 @@ -- | -- Module : Grisette.Internal.Backend.Solving --- Copyright : (c) Sirui Lu 2021-2023 +-- Copyright : (c) Sirui Lu 2021-2024 -- License : BSD-3-Clause (see the LICENSE file) -- -- Maintainer : siruilu@cs.washington.edu @@ -22,15 +22,24 @@ -- Portability : GHC only module Grisette.Internal.Backend.Solving ( -- * SBV backend configuration + GrisetteSMTConfig (..), + boolector, + bitwuzla, + cvc4, + cvc5, + yices, + dReal, + z3, + mathSAT, + abc, + + -- * Changing the extra configurations ApproximationConfig (..), ExtraConfig (..), precise, - approx, + approximate, withTimeout, clearTimeout, - withApprox, - clearApprox, - GrisetteSMTConfig (..), -- * SBV monadic solver interface SBVIncrementalT, @@ -236,10 +245,10 @@ -- > (bvadd a #x9) -- -- Here the value 9 will be approximated to a 4-bit bit vector, and the --- operation `bvadd` will be used instead of `+`. +-- operation @bvadd@ will be used instead of @+@. -- --- Note that this approximation may not be sound. See 'GrisetteSMTConfig' for --- more details. +-- Note that this approximation may not be sound, and usually you should not use +-- this feature. See 'approximate' for more details. data ApproximationConfig (n :: Nat) where NoApprox :: ApproximationConfig 0 Approx :: @@ -256,6 +265,17 @@ integerApprox :: ApproximationConfig i } +-- | Solver configuration for the Grisette SBV backend. +-- +-- A Grisette solver configuration consists of a SBV solver configuration and +-- some extra configurations. +-- +-- You should start with the predefined configurations. +data GrisetteSMTConfig (i :: Nat) = GrisetteSMTConfig + { sbvConfig :: SBV.SMTConfig, + extraConfig :: ExtraConfig i + } + preciseExtraConfig :: ExtraConfig 0 preciseExtraConfig = ExtraConfig @@ -263,20 +283,61 @@ integerApprox = NoApprox } -approximateExtraConfig :: - (KnownNat n, SBV.BVIsNonZero n, KnownIsZero n) => - p n -> - ExtraConfig n -approximateExtraConfig p = - ExtraConfig - { timeout = Nothing, - integerApprox = Approx p - } +-- | Solver configuration for Boolector. +boolector :: GrisetteSMTConfig 0 +boolector = GrisetteSMTConfig SBV.boolector preciseExtraConfig --- | Solver configuration for the Grisette SBV backend. --- A Grisette solver configuration consists of a SBV solver configuration and --- the reasoning precision. +-- | Solver configuration for Bitwuzla. +bitwuzla :: GrisetteSMTConfig 0 +bitwuzla = GrisetteSMTConfig SBV.bitwuzla preciseExtraConfig + +-- | Solver configuration for CVC4. +cvc4 :: GrisetteSMTConfig 0 +cvc4 = GrisetteSMTConfig SBV.cvc4 preciseExtraConfig + +-- | Solver configuration for CVC5. +cvc5 :: GrisetteSMTConfig 0 +cvc5 = GrisetteSMTConfig SBV.cvc5 preciseExtraConfig + +-- | Solver configuration for Yices. +yices :: GrisetteSMTConfig 0 +yices = GrisetteSMTConfig SBV.yices preciseExtraConfig + +-- | Solver configuration for DReal. +dReal :: GrisetteSMTConfig 0 +dReal = GrisetteSMTConfig SBV.dReal preciseExtraConfig + +-- | Solver configuration for Z3. +z3 :: GrisetteSMTConfig 0 +z3 = GrisetteSMTConfig SBV.z3 preciseExtraConfig + +-- | Solver configuration for MathSAT. +mathSAT :: GrisetteSMTConfig 0 +mathSAT = GrisetteSMTConfig SBV.mathSAT preciseExtraConfig + +-- | Solver configuration for ABC. +abc :: GrisetteSMTConfig 0 +abc = GrisetteSMTConfig SBV.abc preciseExtraConfig + +-- | Set to perform precise reasoning with the solver configuration. +precise :: GrisetteSMTConfig n -> GrisetteSMTConfig 0 +precise config = + config {extraConfig = (extraConfig config) {integerApprox = NoApprox}} + +-- | Set to perform approximate reasoning with the solver configuration. -- +-- __Note:__ This isn't the preferred way to control the reasoning precision. +-- A better way is to write your symbolic evaluation code in a generic way, and +-- control the evaluation with the types. +-- +-- >>> f :: (Num a) => a -> a -> a; f x y = x + y +-- >>> solve z3 $ f "a" 5 .== (2 :: SymInteger) +-- Right (Model {a -> -3 :: Integer}) +-- >>> solve z3 $ f "a" 5 .== (2 :: SymWordN 4) +-- Right (Model {a -> 0xd :: WordN 4}) +-- +-- __Description:__ +-- -- Integers can be unbounded (mathematical integer) or bounded (machine -- integer/bit vector). The two types of integers have their own use cases, -- and should be used to model different systems. @@ -291,9 +352,9 @@ -- infinite precision during the symbolic evaluation, but when solving the -- queries, they are translated to bit vectors for better performance. -- --- For example, the Grisette term @5 * "a" :: 'SymInteger'@ should be translated --- to the following SMT with the unbounded reasoning configuration (the term --- is @t1@): +-- For example, the Grisette term @5 * "a" :: 'Grisette.SymPrim.SymInteger'@ +-- should be translated to the following SMT with the unbounded reasoning +-- configuration (the term is @t1@): -- -- > (declare-fun a () Int) ; declare symbolic constant a -- > (define-fun c1 () Int 5) ; define the concrete value 5 @@ -325,31 +386,21 @@ -- -- >>> :set -XTypeApplications -XOverloadedStrings -XDataKinds -- >>> let a = "a" :: SymInteger --- >>> solve (precise z3) $ a .> 7 .&& a .< 9 +-- >>> solve z3 $ a .> 7 .&& a .< 9 -- Right (Model {a -> 8 :: Integer}) --- >>> solve (approx (Proxy @4) z3) $ a .> 7 .&& a .< 9 +-- >>> solve (approximate (Proxy @4) z3) $ a .> 7 .&& a .< 9 -- Left Unsat -- -- This may be avoided by setting an large enough reasoning precision to prevent -- overflows. -data GrisetteSMTConfig (i :: Nat) = GrisetteSMTConfig - { sbvConfig :: SBV.SMTConfig, - extraConfig :: ExtraConfig i - } - --- | A precise reasoning configuration with the given SBV solver configuration. -precise :: SBV.SMTConfig -> GrisetteSMTConfig 0 -precise config = GrisetteSMTConfig config preciseExtraConfig - --- | An approximate reasoning configuration with the given SBV solver --- configuration. -approx :: - forall p n. +approximate :: + forall p m n. (KnownNat n, SBV.BVIsNonZero n, KnownIsZero n) => p n -> - SBV.SMTConfig -> + GrisetteSMTConfig m -> GrisetteSMTConfig n -approx p config = GrisetteSMTConfig config (approximateExtraConfig p) +approximate p config = + config {extraConfig = (extraConfig config) {integerApprox = Approx p}} -- | Set the timeout for the solver configuration. withTimeout :: Int -> GrisetteSMTConfig i -> GrisetteSMTConfig i @@ -361,21 +412,6 @@ clearTimeout config = config {extraConfig = (extraConfig config) {timeout = Nothing}} --- | Set the reasoning precision for the solver configuration. -withApprox :: - (KnownNat n, SBV.BVIsNonZero n, KnownIsZero n) => - p n -> - GrisetteSMTConfig i -> - GrisetteSMTConfig n -withApprox p config = - config {extraConfig = (extraConfig config) {integerApprox = Approx p}} - --- | Clear the reasoning precision and perform precise reasoning with the --- solver configuration. -clearApprox :: GrisetteSMTConfig i -> GrisetteSMTConfig 0 -clearApprox config = - config {extraConfig = (extraConfig config) {integerApprox = NoApprox}} - sbvCheckSatResult :: SBVC.CheckSatResult -> SolvingFailure sbvCheckSatResult SBVC.Sat = error "Should not happen" sbvCheckSatResult (SBVC.DSat _) = error "DSat is currently not supported" @@ -522,6 +558,8 @@ configIntroKnownIsZero (GrisetteSMTConfig _ (ExtraConfig _ (Approx _))) r = r configIntroKnownIsZero (GrisetteSMTConfig _ (ExtraConfig _ NoApprox)) r = r +-- | Lower a single primitive term to SBV. With an explicitly provided +-- 'SymBiMap' cache. lowerSinglePrimCached :: forall integerBitWidth a m. (HasCallStack, SBVFreshMonad m) => @@ -540,6 +578,7 @@ ) Nothing -> lowerSinglePrimImpl config t m +-- | Lower a single primitive term to SBV. lowerSinglePrim :: forall integerBitWidth a m. (HasCallStack, SBVFreshMonad m) => @@ -758,6 +797,7 @@ preprocessUIFuncs = Just . fmap (\(a, (_, c)) -> (a, c)) #endif +-- | Parse an SBV model to a Grisette model. parseModel :: forall integerBitWidth. GrisetteSMTConfig integerBitWidth -> diff --git a/src/Grisette/Internal/Backend/SymBiMap.hs b/src/Grisette/Internal/Backend/SymBiMap.hs --- a/src/Grisette/Internal/Backend/SymBiMap.hs +++ b/src/Grisette/Internal/Backend/SymBiMap.hs @@ -29,26 +29,34 @@ ( SomeTypedSymbol, ) +-- | A bidirectional map between symbolic Grisette terms and sbv terms. data SymBiMap = SymBiMap { biMapToSBV :: M.HashMap SomeTerm Dynamic, biMapFromSBV :: M.HashMap String SomeTypedSymbol } deriving (Show) +-- | An empty bidirectional map. emptySymBiMap :: SymBiMap emptySymBiMap = SymBiMap M.empty M.empty +-- | The size of the bidirectional map. sizeBiMap :: SymBiMap -> Int sizeBiMap = M.size . biMapToSBV +-- | Add a new entry to the bidirectional map. addBiMap :: (HasCallStack) => SomeTerm -> Dynamic -> String -> SomeTypedSymbol -> SymBiMap -> SymBiMap addBiMap s d n sb (SymBiMap t f) = SymBiMap (M.insert s d t) (M.insert n sb f) +-- | Add a new entry to the bidirectional map for intermediate values. addBiMapIntermediate :: (HasCallStack) => SomeTerm -> Dynamic -> SymBiMap -> SymBiMap addBiMapIntermediate s d (SymBiMap t f) = SymBiMap (M.insert s d t) f +-- | Find a symbolic Grisette term from a string. findStringToSymbol :: String -> SymBiMap -> Maybe SomeTypedSymbol findStringToSymbol s (SymBiMap _ f) = M.lookup s f +-- | Look up an sbv value with a symbolic Grisette term in the bidirectional +-- map. lookupTerm :: (HasCallStack) => SomeTerm -> SymBiMap -> Maybe Dynamic lookupTerm t m = M.lookup t (biMapToSBV m) diff --git a/src/Grisette/Internal/Core/Control/Monad/CBMCExcept.hs b/src/Grisette/Internal/Core/Control/Monad/CBMCExcept.hs --- a/src/Grisette/Internal/Core/Control/Monad/CBMCExcept.hs +++ b/src/Grisette/Internal/Core/Control/Monad/CBMCExcept.hs @@ -64,10 +64,10 @@ import Data.Functor.Contravariant (Contravariant (contramap)) import Data.Hashable (Hashable) import GHC.Generics (Generic, Generic1) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM) -import Grisette.Internal.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym)) -import Grisette.Internal.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym (evalSym)) +import Grisette.Internal.Core.Data.Class.ExtractSym + ( ExtractSym (extractSym), ) import Grisette.Internal.Core.Data.Class.GenSym ( GenSym (fresh), @@ -82,15 +82,15 @@ rootStrategy1, wrapStrategy, ) -import Grisette.Internal.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Internal.Core.Data.Class.SOrd (SOrd (symCompare, (.<), (.<=), (.>), (.>=))) import Grisette.Internal.Core.Data.Class.SimpleMergeable ( SimpleMergeable (mrgIte), SimpleMergeable1 (liftMrgIte), - UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), + SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), mrgIf, ) import Grisette.Internal.Core.Data.Class.Solver (UnionWithExcept (extractUnionExcept)) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((.==))) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd (symCompare, (.<), (.<=), (.>), (.>=))) import Grisette.Internal.Core.Data.Class.ToCon (ToCon (toCon)) import Grisette.Internal.Core.Data.Class.ToSym (ToSym (toSym)) import Grisette.Internal.Core.Data.Class.TryMerge @@ -105,13 +105,13 @@ deriving newtype (Eq, Eq1, Ord, Ord1, Read, Read1, Show, Show1, Functor, Applicative, Monad, Hashable, NFData) deriving stock (Generic, Lift) -deriving newtype instance (SEq e, SEq a) => SEq (CBMCEither e a) +deriving newtype instance (SymEq e, SymEq a) => SymEq (CBMCEither e a) -deriving newtype instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (CBMCEither a b) +deriving newtype instance (EvalSym a, EvalSym b) => EvalSym (CBMCEither a b) deriving newtype instance - (ExtractSymbolics a, ExtractSymbolics b) => - ExtractSymbolics (CBMCEither a b) + (ExtractSym a, ExtractSym b) => + ExtractSym (CBMCEither a b) instance ( GenSymSimple a a, @@ -135,7 +135,7 @@ where fresh = derivedNoSpecFresh -deriving newtype instance (SOrd a, SOrd b) => SOrd (CBMCEither a b) +deriving newtype instance (SymOrd a, SymOrd b) => SymOrd (CBMCEither a b) deriving newtype instance (ToCon e1 e2, ToCon a1 a2) => ToCon (Either e1 a1) (CBMCEither e2 a2) @@ -209,7 +209,8 @@ withCBMCExceptT :: (Functor m) => (e -> e') -> CBMCExceptT e m a -> CBMCExceptT e' m a withCBMCExceptT f = mapCBMCExceptT $ fmap $ either (Left . f) Right --- | Similar to 'ExceptT', but with different error handling mechanism. +-- | Similar to 'Control.Monad.Except.ExceptT', but with different error +-- handling mechanism. newtype CBMCExceptT e m a = CBMCExceptT {runCBMCExceptT :: m (CBMCEither e a)} deriving stock (Generic, Generic1) instance (Eq e, Eq1 m) => Eq1 (CBMCExceptT e m) where @@ -353,19 +354,19 @@ catchError = catchE {-# INLINE catchError #-} -instance (SEq (m (CBMCEither e a))) => SEq (CBMCExceptT e m a) where +instance (SymEq (m (CBMCEither e a))) => SymEq (CBMCExceptT e m a) where (CBMCExceptT a) .== (CBMCExceptT b) = a .== b {-# INLINE (.==) #-} -instance (EvaluateSym (m (CBMCEither e a))) => EvaluateSym (CBMCExceptT e m a) where - evaluateSym fillDefault model (CBMCExceptT v) = CBMCExceptT $ evaluateSym fillDefault model v - {-# INLINE evaluateSym #-} +instance (EvalSym (m (CBMCEither e a))) => EvalSym (CBMCExceptT e m a) where + evalSym fillDefault model (CBMCExceptT v) = CBMCExceptT $ evalSym fillDefault model v + {-# INLINE evalSym #-} instance - (ExtractSymbolics (m (CBMCEither e a))) => - ExtractSymbolics (CBMCExceptT e m a) + (ExtractSym (m (CBMCEither e a))) => + ExtractSym (CBMCExceptT e m a) where - extractSymbolics (CBMCExceptT v) = extractSymbolics v + extractSym (CBMCExceptT v) = extractSym v instance (Mergeable1 m, Mergeable e, Mergeable a) => @@ -417,14 +418,14 @@ GenSym (CBMCExceptT e m a) (CBMCExceptT e m a) instance - (UnionMergeable1 m, Mergeable e, Mergeable a) => + (SymBranching m, Mergeable e, Mergeable a) => SimpleMergeable (CBMCExceptT e m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} instance - (UnionMergeable1 m, Mergeable e) => + (SymBranching m, Mergeable e) => SimpleMergeable1 (CBMCExceptT e m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) @@ -438,15 +439,15 @@ {-# INLINE tryMergeWithStrategy #-} instance - (UnionMergeable1 m, Mergeable e) => - UnionMergeable1 (CBMCExceptT e m) + (SymBranching m, Mergeable e) => + SymBranching (CBMCExceptT e m) where mrgIfWithStrategy s cond (CBMCExceptT t) (CBMCExceptT f) = CBMCExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f {-# INLINE mrgIfWithStrategy #-} mrgIfPropagatedStrategy cond (CBMCExceptT t) (CBMCExceptT f) = CBMCExceptT $ mrgIfPropagatedStrategy cond t f {-# INLINE mrgIfPropagatedStrategy #-} -instance (SOrd (m (CBMCEither e a))) => SOrd (CBMCExceptT e m a) where +instance (SymOrd (m (CBMCEither e a))) => SymOrd (CBMCExceptT e m a) where (CBMCExceptT l) .<= (CBMCExceptT r) = l .<= r (CBMCExceptT l) .< (CBMCExceptT r) = l .< r (CBMCExceptT l) .>= (CBMCExceptT r) = l .>= r @@ -477,5 +478,5 @@ where extractUnionExcept = tryMerge . fmap runCBMCEither . runCBMCExceptT -instance UnionWithExcept (UnionM (CBMCEither e v)) UnionM e v where +instance UnionWithExcept (Union (CBMCEither e v)) Union e v where extractUnionExcept = fmap runCBMCEither diff --git a/src/Grisette/Internal/Core/Control/Monad/Class/Union.hs b/src/Grisette/Internal/Core/Control/Monad/Class/Union.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Control/Monad/Class/Union.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Control.Monad.Class.Union +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Control.Monad.Class.Union + ( -- * MonadUnion + MonadUnion, + ) +where + +import Grisette.Internal.Core.Data.Class.SimpleMergeable (SymBranching) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Class for monads that support union-like operations and +-- 'Grisette.Core.Data.Class.Mergeable' knowledge propagation. +type MonadUnion u = (SymBranching u, Monad u) diff --git a/src/Grisette/Internal/Core/Control/Monad/Union.hs b/src/Grisette/Internal/Core/Control/Monad/Union.hs --- a/src/Grisette/Internal/Core/Control/Monad/Union.hs +++ b/src/Grisette/Internal/Core/Control/Monad/Union.hs @@ -1,30 +1,668 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# HLINT ignore "Use <&>" #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} -- | -- Module : Grisette.Internal.Core.Control.Monad.Union --- Copyright : (c) Sirui Lu 2021-2023 +-- Copyright : (c) Sirui Lu 2021-2024 -- License : BSD-3-Clause (see the LICENSE file) -- -- Maintainer : siruilu@cs.washington.edu -- Stability : Experimental -- Portability : GHC only module Grisette.Internal.Core.Control.Monad.Union - ( -- * MonadUnion - MonadUnion, + ( -- * Union and helpers + Union (..), + unionUnaryOp, + unionBinOp, + liftUnion, + liftToMonadUnion, + unionBase, + unionMergingStrategy, + isMerged, + unionSize, + IsConcrete, ) where -import Grisette.Internal.Core.Data.Class.SimpleMergeable (UnionMergeable1) +import Control.Applicative (Alternative ((<|>))) +import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) +import Data.Functor.Classes + ( Eq1 (liftEq), + Show1 (liftShowsPrec), + showsPrec1, + ) +import qualified Data.HashMap.Lazy as HML +import Data.Hashable (Hashable (hashWithSalt)) +import Data.String (IsString (fromString)) +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) +import Grisette.Internal.Core.Data.Class.EvalSym + ( EvalSym (evalSym), + EvalSym1 (liftEvalSym), + evalSym1, + ) +import Grisette.Internal.Core.Data.Class.ExtractSym + ( ExtractSym (extractSym), + ExtractSym1 (liftExtractSym), + extractSym1, + ) +import Grisette.Internal.Core.Data.Class.Function (Function ((#))) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (false, symImplies, symNot, symXor, true, (.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + MergingStrategy (SimpleStrategy), + rootStrategy1, + ) +import Grisette.Internal.Core.Data.Class.PPrint + ( PPrint (pformatPrec), + PPrint1 (liftPFormatPrec), + groupedEnclose, + pformatPrec1, + ) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion (ifView, singleView), + simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (con, conView, sym), + pattern Con, + ) +import Grisette.Internal.Core.Data.Class.Solver + ( UnionWithExcept (extractUnionExcept), + ) +import Grisette.Internal.Core.Data.Class.SubstSym + ( SubstSym (substSym), + SubstSym1 (liftSubstSym), + substSym1, + ) +import Grisette.Internal.Core.Data.Class.SymEq + ( SymEq ((.==)), + SymEq1 (liftSymEq), + symEq1, + ) +import Grisette.Internal.Core.Data.Class.ToCon + ( ToCon (toCon), + ToCon1 (liftToCon), + toCon1, + ) +import Grisette.Internal.Core.Data.Class.ToSym + ( ToSym (toSym), + ToSym1 (liftToSym), + toSym1, + ) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge (tryMergeWithStrategy), + mrgSingle, + mrgSingleWithStrategy, + tryMerge, + ) +import Grisette.Internal.Core.Data.UnionBase + ( UnionBase (UnionIf, UnionSingle), + ifWithLeftMost, + ) +import Grisette.Internal.SymPrim.AllSyms + ( AllSyms (allSymsS), + AllSyms1 (liftAllSymsS), + allSymsS1, + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.GeneralFun + ( type (-->), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN, + SymWordN, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Language.Haskell.TH.Syntax (Lift (lift, liftTyped)) +import Language.Haskell.TH.Syntax.Compat (unTypeSplice) -- $setup -- >>> import Grisette.Core -- >>> import Grisette.SymPrim +-- >>> :set -XScopedTypeVariables --- | Class for monads that support union-like operations and --- 'Grisette.Core.Data.Class.Mergeable' knowledge propagation. -type MonadUnion u = (UnionMergeable1 u, Monad u) +-- | 'Union' is the 'UnionBase' container (hidden) enhanced with +-- 'MergingStrategy' +-- [knowledge propagation](https://okmij.org/ftp/Haskell/set-monad.html#PE). +-- +-- The 'UnionBase' models the underlying semantics evaluation semantics for +-- unsolvable types with the nested if-then-else tree semantics, and can be +-- viewed as the following structure: +-- +-- > data UnionBase a +-- > = UnionSingle a +-- > | UnionIf bool (Union a) (Union a) +-- +-- The 'UnionSingle' constructor is for a single value with the path condition +-- @true@, and the 'UnionIf' constructor is the if operator in an if-then-else +-- tree. +-- For clarity, when printing a 'Union' value, we will omit the 'UnionSingle' +-- constructor. The following two representations has the same semantics. +-- +-- > If c1 (If c11 v11 (If c12 v12 v13)) +-- > (If c2 v2 +-- > v3) +-- +-- \[ +-- \left\{\begin{aligned}&t_1&&\mathrm{if}&&c_1\\&v_2&&\mathrm{else if}&&c_2\\&v_3&&\mathrm{otherwise}&&\end{aligned}\right.\hspace{2em}\mathrm{where}\hspace{2em}t_1 = \left\{\begin{aligned}&v_{11}&&\mathrm{if}&&c_{11}\\&v_{12}&&\mathrm{else if}&&c_{12}\\&v_{13}&&\mathrm{otherwise}&&\end{aligned}\right. +-- \] +-- +-- To reduce the size of the if-then-else tree to reduce the number of paths to +-- execute, Grisette would merge the branches in a 'UnionBase' container and +-- maintain a representation invariant for them. To perform this merging +-- procedure, Grisette relies on a type class called 'Mergeable' and the +-- merging strategy defined by it. +-- +-- 'UnionBase' is a monad, so we can easily write code with the do-notation and +-- monadic combinators. However, the standard monadic operators cannot +-- resolve any extra constraints, including the 'Mergeable' constraint (see +-- [The constrained-monad +-- problem](https://dl.acm.org/doi/10.1145/2500365.2500602) +-- by Sculthorpe et al.). +-- This prevents the standard do-notations to merge the results automatically, +-- and would result in bad performance or very verbose code. +-- +-- To reduce this boilerplate, Grisette provide another monad, 'Union' that +-- would try to cache the merging strategy. +-- The 'Union' has two data constructors (hidden intentionally), 'UAny' and +-- 'UMrg'. The 'UAny' data constructor (printed as @<@@...@@>@) wraps an +-- arbitrary (probably unmerged) 'UnionBase'. It is constructed when no +-- 'Mergeable' knowledge is available (for example, when constructed with +-- Haskell\'s 'return'). The 'UMrg' data constructor (printed as @{...}@) wraps +-- a merged 'UnionBase' along with the 'Mergeable' constraint. This constraint +-- can be propagated to the contexts without 'Mergeable' knowledge, and helps +-- the system to merge the resulting 'UnionBase'. +-- +-- __/Examples:/__ +-- +-- 'return' cannot resolve the 'Mergeable' constraint. +-- +-- >>> return 1 :: Union Integer +-- <1> +-- +-- 'Grisette.Lib.Control.Monad.mrgReturn' can resolve the 'Mergeable' constraint. +-- +-- >>> import Grisette.Lib.Base +-- >>> mrgReturn 1 :: Union Integer +-- {1} +-- +-- 'mrgIfPropagatedStrategy' does not try to 'Mergeable' constraint. +-- +-- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (return 1) (return 2)) :: Union Integer +-- +-- +-- But 'mrgIfPropagatedStrategy' is able to merge the result if some of the +-- branches are merged and have a cached merging strategy: +-- +-- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (mrgReturn 1) (return 2)) :: Union Integer +-- {If (|| a b) 1 2} +-- +-- The '>>=' operator uses 'mrgIfPropagatedStrategy' internally. When the final +-- statement in a do-block merges the values, the system can then merge the +-- final result. +-- +-- >>> :{ +-- do +-- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) +-- mrgSingle $ x + 1 :: Union Integer +-- :} +-- {If (|| a b) 2 3} +-- +-- Calling a function that merges a result at the last line of a do-notation +-- will also merge the whole block. If you stick to these @mrg*@ combinators and +-- all the functions will merge the results, the whole program can be +-- symbolically evaluated efficiently. +-- +-- >>> f x y = mrgIf "c" x y :: Union Integer +-- >>> :{ +-- do +-- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) +-- f x (x + 1) +-- :} +-- {If (&& c (|| a b)) 1 (If (|| a (|| b c)) 2 3)} +-- +-- In "Grisette.Lib.Base", "Grisette.Lib.Mtl", we also provided more @mrg*@ +-- variants of other combinators. You should stick to these combinators to +-- ensure efficient merging by Grisette. +data Union a where + -- | 'Union' with no 'Mergeable' knowledge. + UAny :: + -- | Original 'UnionBase'. + UnionBase a -> + Union a + -- | 'Union' with 'Mergeable' knowledge. + UMrg :: + -- | Cached merging strategy. + MergingStrategy a -> + -- | Merged 'UnionBase' + UnionBase a -> + Union a + +-- | Get the (possibly empty) cached merging strategy. +unionMergingStrategy :: Union a -> Maybe (MergingStrategy a) +unionMergingStrategy (UMrg s _) = Just s +unionMergingStrategy _ = Nothing + +instance (NFData a) => NFData (Union a) where + rnf = rnf1 + +instance NFData1 Union where + liftRnf _a (UAny m) = liftRnf _a m + liftRnf _a (UMrg _ m) = liftRnf _a m + +instance (Lift a) => Lift (Union a) where + liftTyped (UAny v) = [||UAny v||] + liftTyped (UMrg _ v) = [||UAny v||] + lift = unTypeSplice . liftTyped + +instance (Show a) => (Show (Union a)) where + showsPrec = showsPrec1 + +liftShowsPrecUnion :: + forall a. + (Int -> a -> ShowS) -> + ([a] -> ShowS) -> + Int -> + UnionBase a -> + ShowS +liftShowsPrecUnion sp _ i (UnionSingle a) = sp i a +liftShowsPrecUnion sp sl i (UnionIf _ _ cond t f) = + showParen (i > 10) $ + showString "If" + . showChar ' ' + . showsPrec 11 cond + . showChar ' ' + . sp1 11 t + . showChar ' ' + . sp1 11 f + where + sp1 = liftShowsPrecUnion sp sl + +wrapBracket :: Char -> Char -> ShowS -> ShowS +wrapBracket l r p = showChar l . p . showChar r + +instance Show1 Union where + liftShowsPrec sp sl _ (UAny a) = + wrapBracket '<' '>' + . liftShowsPrecUnion sp sl 0 + $ a + liftShowsPrec sp sl _ (UMrg _ a) = + wrapBracket '{' '}' + . liftShowsPrecUnion sp sl 0 + $ a + +instance (PPrint a) => PPrint (Union a) where + pformatPrec = pformatPrec1 + +instance PPrint1 Union where + liftPFormatPrec fa fl _ = \case + (UAny a) -> groupedEnclose "<" ">" $ liftPFormatPrec fa fl 0 a + (UMrg _ a) -> groupedEnclose "{" "}" $ liftPFormatPrec fa fl 0 a + +-- | Extract the underlying Union. May be unmerged. +unionBase :: Union a -> UnionBase a +unionBase (UAny a) = a +unionBase (UMrg _ a) = a +{-# INLINE unionBase #-} + +-- | Check if a 'Union' is already merged. +isMerged :: Union a -> Bool +isMerged UAny {} = False +isMerged UMrg {} = True +{-# INLINE isMerged #-} + +instance PlainUnion Union where + singleView = singleView . unionBase + {-# INLINE singleView #-} + ifView (UAny u) = case ifView u of + Just (c, t, f) -> Just (c, UAny t, UAny f) + Nothing -> Nothing + ifView (UMrg m u) = case ifView u of + Just (c, t, f) -> Just (c, UMrg m t, UMrg m f) + Nothing -> Nothing + {-# INLINE ifView #-} + +instance Functor Union where + fmap f fa = fa >>= return . f + {-# INLINE fmap #-} + +instance Applicative Union where + pure = UAny . pure + {-# INLINE pure #-} + f <*> a = f >>= (\xf -> a >>= (return . xf)) + {-# INLINE (<*>) #-} + +bindUnionBase :: UnionBase a -> (a -> Union b) -> Union b +bindUnionBase (UnionSingle a') f' = f' a' +bindUnionBase (UnionIf _ _ cond ifTrue ifFalse) f' = + mrgIfPropagatedStrategy + cond + (bindUnionBase ifTrue f') + (bindUnionBase ifFalse f') +{-# INLINE bindUnionBase #-} + +instance Monad Union where + a >>= f = bindUnionBase (unionBase a) f + {-# INLINE (>>=) #-} + +-- | Lift a unary operation to 'Union'. +unionUnaryOp :: (a -> a) -> Union a -> Union a +unionUnaryOp f a = do + a1 <- a + maybe return mrgSingleWithStrategy (unionMergingStrategy a) $ f a1 +{-# INLINE unionUnaryOp #-} + +-- | Lift a binary operation to 'Union'. +unionBinOp :: + (a -> a -> a) -> + Union a -> + Union a -> + Union a +unionBinOp f a b = do + a1 <- a + b1 <- b + maybe + return + mrgSingleWithStrategy + (unionMergingStrategy a <|> unionMergingStrategy b) + $ f a1 b1 +{-# INLINE unionBinOp #-} + +instance (Mergeable a) => Mergeable (Union a) where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable a) => SimpleMergeable (Union a) where + mrgIte = mrgIf + {-# INLINE mrgIte #-} + +instance Mergeable1 Union where + liftRootStrategy m = SimpleStrategy $ mrgIfWithStrategy m + {-# INLINE liftRootStrategy #-} + +instance SimpleMergeable1 Union where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + {-# INLINE liftMrgIte #-} + +instance TryMerge Union where + tryMergeWithStrategy _ m@(UMrg _ _) = m + tryMergeWithStrategy s (UAny u) = UMrg s $ tryMergeWithStrategy s u + {-# INLINE tryMergeWithStrategy #-} + +instance SymBranching Union where + mrgIfWithStrategy s (Con c) l r = + if c then tryMergeWithStrategy s l else tryMergeWithStrategy s r + mrgIfWithStrategy s cond l r = + UMrg s $ + mrgIfWithStrategy + s + cond + (unionBase l) + (unionBase r) + {-# INLINE mrgIfWithStrategy #-} + mrgIfPropagatedStrategy cond (UAny t) (UAny f) = + UAny $ ifWithLeftMost False cond t f + mrgIfPropagatedStrategy cond t@(UMrg m _) f = mrgIfWithStrategy m cond t f + mrgIfPropagatedStrategy cond t f@(UMrg m _) = mrgIfWithStrategy m cond t f + {-# INLINE mrgIfPropagatedStrategy #-} + +instance (SymEq a) => SymEq (Union a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance SymEq1 Union where + liftSymEq f x y = simpleMerge $ f <$> x <*> y + {-# INLINE liftSymEq #-} + +-- | Lift the 'Union' to any Applicative 'SymBranching'. +liftUnion :: + forall u a. (Mergeable a, SymBranching u, Applicative u) => Union a -> u a +liftUnion u = go (unionBase u) + where + go :: UnionBase a -> u a + go (UnionSingle v) = mrgSingle v + go (UnionIf _ _ c t f) = mrgIf c (go t) (go f) + +-- | Alias for `liftUnion`, but for monads. +liftToMonadUnion :: (Mergeable a, MonadUnion u) => Union a -> u a +liftToMonadUnion = liftUnion + +instance {-# INCOHERENT #-} (ToSym a b, Mergeable b) => ToSym a (Union b) where + toSym = mrgSingle . toSym + +instance (ToSym a b) => ToSym (Union a) (Union b) where + toSym = toSym1 + +instance ToSym1 Union Union where + liftToSym = fmap + +instance ToSym (Union Bool) SymBool where + toSym = simpleMerge . fmap con + +instance ToSym (Union Integer) SymInteger where + toSym = simpleMerge . fmap con + +instance (KnownNat n, 1 <= n) => ToSym (Union (IntN n)) (SymIntN n) where + toSym = simpleMerge . fmap con + +instance (KnownNat n, 1 <= n) => ToSym (Union (WordN n)) (SymWordN n) where + toSym = simpleMerge . fmap con + +instance + (SupportedPrim ((=->) ca cb), LinkedRep ca sa, LinkedRep cb sb) => + ToSym (Union ((=->) ca cb)) ((=~>) sa sb) + where + toSym = simpleMerge . fmap con + +instance + (SupportedPrim ((-->) ca cb), LinkedRep ca sa, LinkedRep cb sb) => + ToSym (Union ((-->) ca cb)) ((-~>) sa sb) + where + toSym = simpleMerge . fmap con + +instance {-# INCOHERENT #-} (ToCon a b, Mergeable a) => ToCon (Union a) b where + toCon v = go $ unionBase $ tryMerge v + where + go (UnionSingle x) = toCon x + go _ = Nothing + +instance (ToCon a b) => ToCon (Union a) (Union b) where + toCon = toCon1 + +instance ToCon1 Union Union where + liftToCon f v = go $ unionBase v + where + go (UnionSingle x) = case f x of + Nothing -> Nothing + Just v -> Just $ return v + go (UnionIf _ _ c t f) = do + t' <- go t + f' <- go f + return $ mrgIfPropagatedStrategy c t' f' + +instance (EvalSym a) => EvalSym (Union a) where + evalSym = evalSym1 + +instance EvalSym1 Union where + liftEvalSym f fillDefault model x = go $ unionBase x + where + go (UnionSingle v) = single $ f fillDefault model v + go (UnionIf _ _ cond t f) = + unionIf (evalSym fillDefault model cond) (go t) (go f) + strategy = unionMergingStrategy x + single = maybe return mrgSingleWithStrategy strategy + unionIf = maybe mrgIfPropagatedStrategy mrgIfWithStrategy strategy + +instance (SubstSym a) => SubstSym (Union a) where + substSym = substSym1 + +instance SubstSym1 Union where + liftSubstSym f sym val x = go $ unionBase x + where + go (UnionSingle v) = single $ f sym val v + go (UnionIf _ _ cond t f) = + unionIf + (substSym sym val cond) + (go t) + (go f) + strategy = unionMergingStrategy x + single = maybe return mrgSingleWithStrategy strategy + unionIf = maybe mrgIfPropagatedStrategy mrgIfWithStrategy strategy + +instance (ExtractSym a) => ExtractSym (Union a) where + extractSym = extractSym1 + +instance ExtractSym1 Union where + liftExtractSym e v = go $ unionBase v + where + go (UnionSingle x) = e x + go (UnionIf _ _ cond t f) = extractSym cond <> go t <> go f + +instance (Hashable a) => Hashable (Union a) where + s `hashWithSalt` (UAny u) = s `hashWithSalt` (0 :: Int) `hashWithSalt` u + s `hashWithSalt` (UMrg _ u) = s `hashWithSalt` (1 :: Int) `hashWithSalt` u + +instance (Eq a) => Eq (Union a) where + UAny l == UAny r = l == r + UMrg _ l == UMrg _ r = l == r + _ == _ = False + +instance Eq1 Union where + liftEq e l r = liftEq e (unionBase l) (unionBase r) + +instance (Num a, Mergeable a) => Num (Union a) where + fromInteger = mrgSingle . fromInteger + negate = unionUnaryOp negate + (+) = unionBinOp (+) + (*) = unionBinOp (*) + (-) = unionBinOp (-) + abs = unionUnaryOp abs + signum = unionUnaryOp signum + +instance (ITEOp a, Mergeable a) => ITEOp (Union a) where + symIte = mrgIf + +instance (LogicalOp a, Mergeable a) => LogicalOp (Union a) where + true = mrgSingle true + false = mrgSingle false + (.||) = unionBinOp (.||) + (.&&) = unionBinOp (.&&) + symNot = unionUnaryOp symNot + symXor = unionBinOp symXor + symImplies = unionBinOp symImplies + +instance (Solvable c t, Mergeable t) => Solvable c (Union t) where + con = mrgSingle . con + {-# INLINE con #-} + sym = mrgSingle . sym + {-# INLINE sym #-} + conView v = do + c <- singleView $ tryMerge v + conView c + {-# INLINE conView #-} + +instance + (Function f arg ret, Mergeable f, Mergeable ret) => + Function (Union f) arg (Union ret) + where + f # a = do + f1 <- f + mrgSingle $ f1 # a + +instance (IsString a, Mergeable a) => IsString (Union a) where + fromString = mrgSingle . fromString + +-- AllSyms +instance (AllSyms a) => AllSyms (Union a) where + allSymsS = allSymsS1 + +instance AllSyms1 Union where + liftAllSymsS f = liftAllSymsS f . unionBase + +-- Concrete Key HashMaps + +-- | Tag for concrete types. +-- Useful for specifying the merge strategy for some parametrized types where we should have different +-- merge strategy for symbolic and concrete ones. +class (Eq t, Ord t, Hashable t) => IsConcrete t + +instance IsConcrete Bool + +instance IsConcrete Integer + +instance (IsConcrete k, Mergeable t) => Mergeable (HML.HashMap k (Union (Maybe t))) where + rootStrategy = SimpleStrategy mrgIte + +instance (IsConcrete k, Mergeable t) => SimpleMergeable (HML.HashMap k (Union (Maybe t))) where + mrgIte cond l r = + HML.unionWith (mrgIf cond) ul ur + where + ul = + foldr + ( \k m -> case HML.lookup k m of + Nothing -> HML.insert k (mrgSingle Nothing) m + _ -> m + ) + l + (HML.keys r) + ur = + foldr + ( \k m -> case HML.lookup k m of + Nothing -> HML.insert k (mrgSingle Nothing) m + _ -> m + ) + r + (HML.keys l) + +instance UnionWithExcept (Union (Either e v)) Union e v where + extractUnionExcept = id + +-- | The size of a union is defined as the number of branches. +-- For example, +-- +-- >>> unionSize (return True) +-- 1 +-- >>> unionSize (mrgIf "a" (return 1) (return 2) :: Union Integer) +-- 2 +-- >>> unionSize (choose [1..7] "a" :: Union Integer) +-- 7 +unionSize :: Union a -> Int +unionSize = unionSize' . unionBase + where + unionSize' (UnionSingle _) = 1 + unionSize' (UnionIf _ _ _ l r) = unionSize' l + unionSize' r diff --git a/src/Grisette/Internal/Core/Control/Monad/UnionM.hs b/src/Grisette/Internal/Core/Control/Monad/UnionM.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core/Control/Monad/UnionM.hs +++ /dev/null @@ -1,594 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# HLINT ignore "Use <&>" #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - --- | --- Module : Grisette.Internal.Core.Control.Monad.UnionM --- Copyright : (c) Sirui Lu 2021-2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.Control.Monad.UnionM - ( -- * UnionM and helpers - UnionM (..), - unionMUnaryOp, - unionMBinOp, - liftUnionM, - liftToMonadUnion, - underlyingUnion, - isMerged, - unionSize, - IsConcrete, - ) -where - -import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) -import Data.Functor.Classes - ( Eq1 (liftEq), - Show1 (liftShowsPrec), - showsPrec1, - ) -import qualified Data.HashMap.Lazy as HML -import Data.Hashable (Hashable (hashWithSalt)) -import Data.String (IsString (fromString)) -import GHC.TypeNats (KnownNat, type (<=)) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) -import Grisette.Internal.Core.Data.Class.EvaluateSym (EvaluateSym (evaluateSym)) -import Grisette.Internal.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), - ) -import Grisette.Internal.Core.Data.Class.Function (Function ((#))) -import Grisette.Internal.Core.Data.Class.GPretty - ( GPretty (gpretty), - groupedEnclose, - ) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Internal.Core.Data.Class.LogicalOp - ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)), - ) -import Grisette.Internal.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable1 (liftRootStrategy), - MergingStrategy (SimpleStrategy), - ) -import Grisette.Internal.Core.Data.Class.PlainUnion - ( PlainUnion (ifView, singleView), - simpleMerge, - ) -import Grisette.Internal.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Internal.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - SimpleMergeable1 (liftMrgIte), - UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), - mrgIf, - ) -import Grisette.Internal.Core.Data.Class.Solvable - ( Solvable (con, conView, sym), - pattern Con, - ) -import Grisette.Internal.Core.Data.Class.Solver (UnionWithExcept (extractUnionExcept)) -import Grisette.Internal.Core.Data.Class.SubstituteSym (SubstituteSym (substituteSym)) -import Grisette.Internal.Core.Data.Class.ToCon (ToCon (toCon)) -import Grisette.Internal.Core.Data.Class.ToSym (ToSym (toSym)) -import Grisette.Internal.Core.Data.Class.TryMerge - ( TryMerge (tryMergeWithStrategy), - mrgSingle, - tryMerge, - ) -import Grisette.Internal.Core.Data.Union - ( Union (UnionIf, UnionSingle), - ifWithLeftMost, - ) -import Grisette.Internal.SymPrim.AllSyms - ( AllSyms (allSymsS), - ) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.GeneralFun - ( type (-->), - ) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedPrim, - ) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN, - SymWordN, - ) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) -import Language.Haskell.TH.Syntax (Lift (lift, liftTyped)) -import Language.Haskell.TH.Syntax.Compat (unTypeSplice) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> :set -XScopedTypeVariables - --- | 'UnionM' is the 'Union' container (hidden) enhanced with --- 'MergingStrategy' --- [knowledge propagation](https://okmij.org/ftp/Haskell/set-monad.html#PE). --- --- The 'Union' models the underlying semantics evaluation semantics for --- unsolvable types with the nested if-then-else tree semantics, and can be --- viewed as the following structure: --- --- > data Union a --- > = Single a --- > | If bool (Union a) (Union a) --- --- The 'Single' constructor is for a single value with the path condition --- @true@, and the 'If' constructor is the if operator in an if-then-else --- tree. --- For clarity, when printing a 'UnionM' value, we will omit the 'Single' --- constructor. The following two representations has the same semantics. --- --- > If c1 (If c11 v11 (If c12 v12 v13)) --- > (If c2 v2 --- > v3) --- --- \[ --- \left\{\begin{aligned}&t_1&&\mathrm{if}&&c_1\\&v_2&&\mathrm{else if}&&c_2\\&v_3&&\mathrm{otherwise}&&\end{aligned}\right.\hspace{2em}\mathrm{where}\hspace{2em}t_1 = \left\{\begin{aligned}&v_{11}&&\mathrm{if}&&c_{11}\\&v_{12}&&\mathrm{else if}&&c_{12}\\&v_{13}&&\mathrm{otherwise}&&\end{aligned}\right. --- \] --- --- To reduce the size of the if-then-else tree to reduce the number of paths to --- execute, Grisette would merge the branches in a 'Union' container and --- maintain a representation invariant for them. To perform this merging --- procedure, Grisette relies on a type class called 'Mergeable' and the --- merging strategy defined by it. --- --- 'Union' is a monad, so we can easily write code with the do-notation and --- monadic combinators. However, the standard monadic operators cannot --- resolve any extra constraints, including the 'Mergeable' constraint (see --- [The constrained-monad --- problem](https://dl.acm.org/doi/10.1145/2500365.2500602) --- by Sculthorpe et al.). --- This prevents the standard do-notations to merge the results automatically, --- and would result in bad performance or very verbose code. --- --- To reduce this boilerplate, Grisette provide another monad, 'UnionM' that --- would try to cache the merging strategy. --- The 'UnionM' has two data constructors (hidden intentionally), 'UAny' and 'UMrg'. --- The 'UAny' data constructor (printed as @<@@...@@>@) wraps an arbitrary (probably --- unmerged) 'Union'. It is constructed when no 'Mergeable' knowledge is --- available (for example, when constructed with Haskell\'s 'return'). --- The 'UMrg' data constructor (printed as @{...}@) wraps a merged 'UnionM' along with the --- 'Mergeable' constraint. This constraint can be propagated to the contexts --- without 'Mergeable' knowledge, and helps the system to merge the resulting --- 'Union'. --- --- __/Examples:/__ --- --- 'return' cannot resolve the 'Mergeable' constraint. --- --- >>> return 1 :: UnionM Integer --- <1> --- --- 'Grisette.Lib.Control.Monad.mrgReturn' can resolve the 'Mergeable' constraint. --- --- >>> import Grisette.Lib.Base --- >>> mrgReturn 1 :: UnionM Integer --- {1} --- --- 'mrgIfPropagatedStrategy' does not try to 'Mergeable' constraint. --- --- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (return 1) (return 2)) :: UnionM Integer --- --- --- But 'mrgIfPropagatedStrategy' is able to merge the result if some of the --- branches are merged and have a cached merging strategy: --- --- >>> mrgIfPropagatedStrategy "a" (return 1) (mrgIfPropagatedStrategy "b" (mrgReturn 1) (return 2)) :: UnionM Integer --- {If (|| a b) 1 2} --- --- The '>>=' operator uses 'mrgIfPropagatedStrategy' internally. When the final --- statement in a do-block merges the values, the system can then merge the --- final result. --- --- >>> :{ --- do --- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) --- mrgSingle $ x + 1 :: UnionM Integer --- :} --- {If (|| a b) 2 3} --- --- Calling a function that merges a result at the last line of a do-notation --- will also merge the whole block. If you stick to these @mrg*@ combinators and --- all the functions will merge the results, the whole program can be --- symbolically evaluated efficiently. --- --- >>> f x y = mrgIf "c" x y --- >>> :{ --- do --- x <- mrgIfPropagatedStrategy (ssym "a") (return 1) (mrgIfPropagatedStrategy (ssym "b") (return 1) (return 2)) --- f x (x + 1) :: UnionM Integer --- :} --- {If (&& c (|| a b)) 1 (If (|| a (|| b c)) 2 3)} --- --- In "Grisette.Lib.Base", "Grisette.Lib.Mtl", we also provided more @mrg*@ --- variants of other combinators. You should stick to these combinators to --- ensure efficient merging by Grisette. -data UnionM a where - -- | 'UnionM' with no 'Mergeable' knowledge. - UAny :: - -- | Original 'Union'. - Union a -> - UnionM a - -- | 'UnionM' with 'Mergeable' knowledge. - UMrg :: - -- | Cached merging strategy. - MergingStrategy a -> - -- | Merged Union - Union a -> - UnionM a - -instance (NFData a) => NFData (UnionM a) where - rnf = rnf1 - -instance NFData1 UnionM where - liftRnf _a (UAny m) = liftRnf _a m - liftRnf _a (UMrg _ m) = liftRnf _a m - -instance (Lift a) => Lift (UnionM a) where - liftTyped (UAny v) = [||UAny v||] - liftTyped (UMrg _ v) = [||UAny v||] - lift = unTypeSplice . liftTyped - -instance (Show a) => (Show (UnionM a)) where - showsPrec = showsPrec1 - -liftShowsPrecUnion :: - forall a. - (Int -> a -> ShowS) -> - ([a] -> ShowS) -> - Int -> - Union a -> - ShowS -liftShowsPrecUnion sp _ i (UnionSingle a) = sp i a -liftShowsPrecUnion sp sl i (UnionIf _ _ cond t f) = - showParen (i > 10) $ - showString "If" - . showChar ' ' - . showsPrec 11 cond - . showChar ' ' - . sp1 11 t - . showChar ' ' - . sp1 11 f - where - sp1 = liftShowsPrecUnion sp sl - -wrapBracket :: Char -> Char -> ShowS -> ShowS -wrapBracket l r p = showChar l . p . showChar r - -instance Show1 UnionM where - liftShowsPrec sp sl _ (UAny a) = - wrapBracket '<' '>' - . liftShowsPrecUnion sp sl 0 - $ a - liftShowsPrec sp sl _ (UMrg _ a) = - wrapBracket '{' '}' - . liftShowsPrecUnion sp sl 0 - $ a - -instance (GPretty a) => GPretty (UnionM a) where - gpretty = \case - (UAny a) -> groupedEnclose "<" ">" $ gpretty a - (UMrg _ a) -> groupedEnclose "{" "}" $ gpretty a - --- | Extract the underlying Union. May be unmerged. -underlyingUnion :: UnionM a -> Union a -underlyingUnion (UAny a) = a -underlyingUnion (UMrg _ a) = a -{-# INLINE underlyingUnion #-} - --- | Check if a UnionM is already merged. -isMerged :: UnionM a -> Bool -isMerged UAny {} = False -isMerged UMrg {} = True -{-# INLINE isMerged #-} - -instance PlainUnion UnionM where - singleView = singleView . underlyingUnion - {-# INLINE singleView #-} - ifView (UAny u) = case ifView u of - Just (c, t, f) -> Just (c, UAny t, UAny f) - Nothing -> Nothing - ifView (UMrg m u) = case ifView u of - Just (c, t, f) -> Just (c, UMrg m t, UMrg m f) - Nothing -> Nothing - {-# INLINE ifView #-} - -instance Functor UnionM where - fmap f fa = fa >>= return . f - {-# INLINE fmap #-} - -instance Applicative UnionM where - pure = UAny . pure - {-# INLINE pure #-} - f <*> a = f >>= (\xf -> a >>= (return . xf)) - {-# INLINE (<*>) #-} - -bindUnion :: Union a -> (a -> UnionM b) -> UnionM b -bindUnion (UnionSingle a') f' = f' a' -bindUnion (UnionIf _ _ cond ifTrue ifFalse) f' = - mrgIfPropagatedStrategy cond (bindUnion ifTrue f') (bindUnion ifFalse f') -{-# INLINE bindUnion #-} - -instance Monad UnionM where - a >>= f = bindUnion (underlyingUnion a) f - {-# INLINE (>>=) #-} - -unionMUnaryOp :: (Mergeable a, Mergeable b) => (a -> b) -> UnionM a -> UnionM b -unionMUnaryOp f a = do - a1 <- tryMerge a - mrgSingle $ f a1 -{-# INLINE unionMUnaryOp #-} - -unionMBinOp :: - (Mergeable a, Mergeable b, Mergeable c) => - (a -> b -> c) -> - UnionM a -> - UnionM b -> - UnionM c -unionMBinOp f a b = do - a1 <- tryMerge a - b1 <- tryMerge b - mrgSingle $ f a1 b1 -{-# INLINE unionMBinOp #-} - -instance (Mergeable a) => Mergeable (UnionM a) where - rootStrategy = SimpleStrategy mrgIf - {-# INLINE rootStrategy #-} - -instance (Mergeable a) => SimpleMergeable (UnionM a) where - mrgIte = mrgIf - {-# INLINE mrgIte #-} - -instance Mergeable1 UnionM where - liftRootStrategy m = SimpleStrategy $ mrgIfWithStrategy m - {-# INLINE liftRootStrategy #-} - -instance SimpleMergeable1 UnionM where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - {-# INLINE liftMrgIte #-} - -instance TryMerge UnionM where - tryMergeWithStrategy _ m@(UMrg _ _) = m - tryMergeWithStrategy s (UAny u) = UMrg s $ tryMergeWithStrategy s u - {-# INLINE tryMergeWithStrategy #-} - -instance UnionMergeable1 UnionM where - mrgIfWithStrategy s (Con c) l r = - if c then tryMergeWithStrategy s l else tryMergeWithStrategy s r - mrgIfWithStrategy s cond l r = - UMrg s $ mrgIfWithStrategy s cond (underlyingUnion l) (underlyingUnion r) - {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (UAny t) (UAny f) = UAny $ ifWithLeftMost False cond t f - mrgIfPropagatedStrategy cond t@(UMrg m _) f = mrgIfWithStrategy m cond t f - mrgIfPropagatedStrategy cond t f@(UMrg m _) = mrgIfWithStrategy m cond t f - {-# INLINE mrgIfPropagatedStrategy #-} - -instance (Mergeable a, SEq a) => SEq (UnionM a) where - x .== y = simpleMerge $ unionMBinOp (.==) x y - {-# INLINE (.==) #-} - --- | Lift the 'UnionM' to any Applicative 'UnionMergeable1'. -liftUnionM :: (Mergeable a, UnionMergeable1 u, Applicative u) => UnionM a -> u a -liftUnionM u = go (underlyingUnion u) - where - go (UnionSingle v) = mrgSingle v - go (UnionIf _ _ c t f) = mrgIf c (go t) (go f) - --- | Alias for `liftUnionM`, but for monads. -liftToMonadUnion :: (Mergeable a, MonadUnion u) => UnionM a -> u a -liftToMonadUnion = liftUnionM - -instance {-# INCOHERENT #-} (ToSym a b, Mergeable b) => ToSym a (UnionM b) where - toSym = mrgSingle . toSym - -instance (ToSym a b, Mergeable b) => ToSym (UnionM a) (UnionM b) where - toSym = tryMerge . fmap toSym - -#define TO_SYM_FROM_UNION_CON_SIMPLE(contype, symtype) \ -instance ToSym (UnionM contype) symtype where \ - toSym = simpleMerge . fmap con - -#define TO_SYM_FROM_UNION_CON_BV(contype, symtype) \ -instance (KnownNat n, 1 <= n) => ToSym (UnionM (contype n)) (symtype n) where \ - toSym = simpleMerge . fmap con - -#define TO_SYM_FROM_UNION_CON_FUN(conop, symop) \ -instance (SupportedPrim (conop ca cb), LinkedRep ca sa, LinkedRep cb sb) => ToSym (UnionM (conop ca cb)) (symop sa sb) where \ - toSym = simpleMerge . fmap con - -#define TO_SYM_FROM_UNION_CON_BV_SOME(contype, symtype) \ -instance ToSym (UnionM contype) symtype where \ - toSym = simpleMerge . fmap (toSym :: contype -> symtype) - -#if 1 -TO_SYM_FROM_UNION_CON_SIMPLE(Bool, SymBool) -TO_SYM_FROM_UNION_CON_SIMPLE(Integer, SymInteger) -TO_SYM_FROM_UNION_CON_BV(IntN, SymIntN) -TO_SYM_FROM_UNION_CON_BV(WordN, SymWordN) -TO_SYM_FROM_UNION_CON_FUN((=->), (=~>)) -TO_SYM_FROM_UNION_CON_FUN((-->), (-~>)) -#endif - -instance {-# INCOHERENT #-} (ToCon a b, Mergeable a) => ToCon (UnionM a) b where - toCon v = go $ underlyingUnion $ tryMerge v - where - go (UnionSingle x) = toCon x - go _ = Nothing - -instance - (ToCon a b, Mergeable a, Mergeable b) => - ToCon (UnionM a) (UnionM b) - where - toCon v = go $ underlyingUnion $ tryMerge v - where - go (UnionSingle x) = case toCon x of - Nothing -> Nothing - Just v -> Just $ mrgSingle v - go (UnionIf _ _ c t f) = do - t' <- go t - f' <- go f - return $ mrgIf c t' f' - -instance (Mergeable a, EvaluateSym a) => EvaluateSym (UnionM a) where - evaluateSym fillDefault model x = go $ underlyingUnion x - where - go :: Union a -> UnionM a - go (UnionSingle v) = mrgSingle $ evaluateSym fillDefault model v - go (UnionIf _ _ cond t f) = - mrgIf - (evaluateSym fillDefault model cond) - (go t) - (go f) - -instance (Mergeable a, SubstituteSym a) => SubstituteSym (UnionM a) where - substituteSym sym val x = go $ underlyingUnion x - where - go :: Union a -> UnionM a - go (UnionSingle v) = mrgSingle $ substituteSym sym val v - go (UnionIf _ _ cond t f) = - mrgIf - (substituteSym sym val cond) - (go t) - (go f) - -instance - (ExtractSymbolics a) => - ExtractSymbolics (UnionM a) - where - extractSymbolics v = go $ underlyingUnion v - where - go (UnionSingle x) = extractSymbolics x - go (UnionIf _ _ cond t f) = extractSymbolics cond <> go t <> go f - -instance (Hashable a) => Hashable (UnionM a) where - s `hashWithSalt` (UAny u) = s `hashWithSalt` (0 :: Int) `hashWithSalt` u - s `hashWithSalt` (UMrg _ u) = s `hashWithSalt` (1 :: Int) `hashWithSalt` u - -instance (Eq a) => Eq (UnionM a) where - UAny l == UAny r = l == r - UMrg _ l == UMrg _ r = l == r - _ == _ = False - -instance Eq1 UnionM where - liftEq e l r = liftEq e (underlyingUnion l) (underlyingUnion r) - -instance (Num a, Mergeable a) => Num (UnionM a) where - fromInteger = mrgSingle . fromInteger - negate = unionMUnaryOp negate - (+) = unionMBinOp (+) - (*) = unionMBinOp (*) - (-) = unionMBinOp (-) - abs = unionMUnaryOp abs - signum = unionMUnaryOp signum - -instance (ITEOp a, Mergeable a) => ITEOp (UnionM a) where - symIte = mrgIf - -instance (LogicalOp a, Mergeable a) => LogicalOp (UnionM a) where - (.||) = unionMBinOp (.||) - (.&&) = unionMBinOp (.&&) - symNot = unionMUnaryOp symNot - symXor = unionMBinOp symXor - symImplies = unionMBinOp symImplies - -instance (Solvable c t, Mergeable t) => Solvable c (UnionM t) where - con = mrgSingle . con - {-# INLINE con #-} - sym = mrgSingle . sym - {-# INLINE sym #-} - conView v = do - c <- singleView $ tryMerge v - conView c - {-# INLINE conView #-} - -instance - (Function f arg ret, Mergeable f, Mergeable ret) => - Function (UnionM f) arg (UnionM ret) - where - f # a = do - f1 <- f - mrgSingle $ f1 # a - -instance (IsString a, Mergeable a) => IsString (UnionM a) where - fromString = mrgSingle . fromString - --- AllSyms -instance (AllSyms a) => AllSyms (UnionM a) where - allSymsS = allSymsS . underlyingUnion - --- Concrete Key HashMaps - --- | Tag for concrete types. --- Useful for specifying the merge strategy for some parametrized types where we should have different --- merge strategy for symbolic and concrete ones. -class (Eq t, Ord t, Hashable t) => IsConcrete t - -instance IsConcrete Bool - -instance IsConcrete Integer - -instance (IsConcrete k, Mergeable t) => Mergeable (HML.HashMap k (UnionM (Maybe t))) where - rootStrategy = SimpleStrategy mrgIte - -instance (IsConcrete k, Mergeable t) => SimpleMergeable (HML.HashMap k (UnionM (Maybe t))) where - mrgIte cond l r = - HML.unionWith (mrgIf cond) ul ur - where - ul = - foldr - ( \k m -> case HML.lookup k m of - Nothing -> HML.insert k (mrgSingle Nothing) m - _ -> m - ) - l - (HML.keys r) - ur = - foldr - ( \k m -> case HML.lookup k m of - Nothing -> HML.insert k (mrgSingle Nothing) m - _ -> m - ) - r - (HML.keys l) - -instance UnionWithExcept (UnionM (Either e v)) UnionM e v where - extractUnionExcept = id - --- | The size of a union is defined as the number of branches. --- For example, --- --- >>> unionSize (return True) --- 1 --- >>> unionSize (mrgIf "a" (return 1) (return 2) :: UnionM Integer) --- 2 --- >>> unionSize (choose [1..7] "a" :: UnionM Integer) --- 7 -unionSize :: UnionM a -> Int -unionSize = unionSize' . underlyingUnion - where - unionSize' (UnionSingle _) = 1 - unionSize' (UnionIf _ _ _ l r) = unionSize' l + unionSize' r diff --git a/src/Grisette/Internal/Core/Data/Class/BitCast.hs b/src/Grisette/Internal/Core/Data/Class/BitCast.hs --- a/src/Grisette/Internal/Core/Data/Class/BitCast.hs +++ b/src/Grisette/Internal/Core/Data/Class/BitCast.hs @@ -5,6 +5,14 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Grisette.Internal.Core.Data.Class.BitCast +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Internal.Core.Data.Class.BitCast (BitCast (..)) where import Control.Monad.ST (ST, runST) @@ -13,6 +21,7 @@ import Data.Int (Int32, Int64) import Data.Word (Word32, Word64) +-- | Type class for bit-casting between types. class BitCast from to where bitCast :: from -> to diff --git a/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs b/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs --- a/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs +++ b/src/Grisette/Internal/Core/Data/Class/CEGISSolver.hs @@ -65,16 +65,16 @@ ) where -import Data.List (partition) +import Data.List (foldl', partition) import GHC.Generics (Generic) import Generics.Deriving (Default (Default)) import Grisette.Internal.Core.Control.Exception ( VerificationConditions (AssertionViolation, AssumptionViolation), ) -import Grisette.Internal.Core.Data.Class.EvaluateSym (EvaluateSym, evaluateSym) -import Grisette.Internal.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics, - extractSymbolics, +import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym, evalSym) +import Grisette.Internal.Core.Data.Class.ExtractSym + ( ExtractSym, + extractSym, ) import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) @@ -86,7 +86,6 @@ ( PlainUnion, simpleMerge, ) -import Grisette.Internal.Core.Data.Class.SEq (SEq) import Grisette.Internal.Core.Data.Class.SimpleMergeable ( SimpleMergeable, ) @@ -99,9 +98,9 @@ solverSolve, withSolver, ) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq) import Grisette.Internal.SymPrim.Prim.Model (Model) import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Lib.Data.Foldable (symAll) -- $setup -- >>> import Grisette.Core @@ -298,7 +297,7 @@ -- behaviors. data CEGISCondition = CEGISCondition SymBool SymBool deriving (Generic) - deriving (EvaluateSym) via (Default CEGISCondition) + deriving (EvalSym) via (Default CEGISCondition) -- | Construct a CEGIS condition with only a post-condition. The pre-condition -- would be set to true, meaning that all programs in the program space are @@ -323,8 +322,8 @@ -- The synthesizer solver will **not** be reset, while the verifier solver will -- be reset after each iteration. solverCegisMultiInputs :: - ( EvaluateSym input, - ExtractSymbolics input, + ( EvalSym input, + ExtractSym input, Solver handle ) => -- The synthesizer solver handle @@ -351,7 +350,7 @@ solverGenericCEGIS synthesizerSolver True - (symAll cexAssertFun conInputs) + (foldl' (\acc v -> acc .&& cexAssertFun v) (con True) conInputs) (return . cexAssertFun) $ getVerifier <$> symInputs where @@ -361,7 +360,7 @@ getVerifier input md = do let CEGISCondition pre post = toCEGISCondition input let evaluated = - evaluateSym False (exceptFor (extractSymbolics input) md) $ + evalSym False (exceptFor (extractSym input) md) $ pre .&& symNot post solverResetAssertions verifierSolver r <- solverSolve verifierSolver evaluated @@ -370,9 +369,9 @@ Left err -> return $ CEGISVerifierException err Right model -> do let newCexInput = - evaluateSym True (exact (extractSymbolics input) model) input + evalSym True (exact (extractSym input) model) input return $ CEGISVerifierFoundCex newCexInput - (conInputs, symInputs) = partition (isEmptySet . extractSymbolics) inputs + (conInputs, symInputs) = partition (isEmptySet . extractSym) inputs -- | CEGIS with a single symbolic input to represent a set of inputs. See -- 'cegis' for more details. @@ -384,9 +383,9 @@ -- be reset after each iteration. solverCegis :: ( Solver handle, - EvaluateSym inputs, - ExtractSymbolics inputs, - SEq inputs + EvalSym inputs, + ExtractSym inputs, + SymEq inputs ) => -- | The synthesizer solver handle handle -> @@ -418,8 +417,8 @@ -- be reset after each iteration. solverCegisExceptMultiInputs :: ( Solver handle, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, UnionWithExcept t u e v, PlainUnion u, Monad u @@ -455,8 +454,8 @@ -- be reset after each iteration. solverCegisExceptVCMultiInputs :: ( Solver handle, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, UnionWithExcept t u e v, PlainUnion u, Monad u @@ -501,8 +500,8 @@ -- be reset after each iteration. solverCegisExceptStdVCMultiInputs :: ( Solver handle, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, UnionWithExcept t u VerificationConditions (), PlainUnion u, Monad u @@ -528,10 +527,10 @@ ( UnionWithExcept t u e v, PlainUnion u, Functor u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, Solver handle, - SEq inputs + SymEq inputs ) => handle -> handle -> @@ -558,10 +557,10 @@ ( UnionWithExcept t u e v, PlainUnion u, Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, Solver handle, - SEq inputs + SymEq inputs ) => handle -> handle -> @@ -592,10 +591,10 @@ ( UnionWithExcept t u VerificationConditions (), PlainUnion u, Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, Solver handle, - SEq inputs + SymEq inputs ) => handle -> handle -> @@ -615,7 +614,7 @@ -- The synthesizer solver will **not** be reset, while the verifier solver will -- be reset after each iteration. solverCegisForAll :: - ( ExtractSymbolics forallInput, + ( ExtractSym forallInput, Solver handle ) => handle -> @@ -637,7 +636,7 @@ synthesizerSolver False phi - (\md -> return $ evaluateSym False md phi) + (\md -> return $ evalSym False md phi) [verifier] let exactResult = case result of CEGISSuccess model -> CEGISSuccess $ exceptFor forallSymbols model @@ -646,10 +645,10 @@ where phi = pre .&& post negphi = pre .&& symNot post - forallSymbols = extractSymbolics input + forallSymbols = extractSym input verifier candidate = do let evaluated = - evaluateSym False (exceptFor forallSymbols candidate) negphi + evalSym False (exceptFor forallSymbols candidate) negphi solverResetAssertions verifierSolver r <- solverSolve verifierSolver evaluated case r of @@ -672,10 +671,10 @@ ( UnionWithExcept t u e v, PlainUnion u, Functor u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, Solver handle, - SEq inputs + SymEq inputs ) => handle -> handle -> @@ -702,10 +701,10 @@ ( UnionWithExcept t u e v, PlainUnion u, Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, Solver handle, - SEq inputs + SymEq inputs ) => handle -> handle -> @@ -737,10 +736,10 @@ ( UnionWithExcept t u VerificationConditions (), PlainUnion u, Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, Solver handle, - SEq inputs + SymEq inputs ) => handle -> handle -> @@ -762,8 +761,8 @@ -- symbolic value, you may want to use 'cegis' or 'cegisExcept' instead. -- We have an example for the 'cegis' call. cegisMultiInputs :: - ( EvaluateSym input, - ExtractSymbolics input, + ( EvalSym input, + ExtractSym input, ConfigurableSolver config handle ) => -- | The configuration of the solver @@ -798,13 +797,13 @@ -- -- >>> :set -XOverloadedStrings -- >>> let [x,c] = ["x","c"] :: [SymInteger] --- >>> cegis (precise z3) x (\x -> cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2)) +-- >>> cegis z3 x (\x -> cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2)) -- (...,CEGISSuccess (Model {c -> -1 :: Integer})) cegis :: ( ConfigurableSolver config handle, - EvaluateSym inputs, - ExtractSymbolics inputs, - SEq inputs + EvalSym inputs, + ExtractSym inputs, + SymEq inputs ) => -- | The configuration of the solver config -> @@ -830,8 +829,8 @@ -- symbolic) inputs to represent a set of inputs. cegisExceptMultiInputs :: ( ConfigurableSolver config handle, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, UnionWithExcept t u e v, PlainUnion u, Monad u @@ -858,8 +857,8 @@ -- The errors should be translated to assertion or assumption violations. cegisExceptVCMultiInputs :: ( ConfigurableSolver config handle, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, UnionWithExcept t u e v, PlainUnion u, Monad u @@ -883,15 +882,15 @@ -- CEGIS for symbolic programs with error handling, using multiple (possibly -- symbolic) inputs to represent a set of inputs. This function saves the -- efforts to implement the translation function for the standard error type --- 'VerificationConditions', and the standard result type '()'. +-- 'VerificationConditions', and the standard result type @()@. -- -- This function translates assumption violations to failed pre-conditions, -- and translates assertion violations to failed post-conditions. --- The '()' result will not fail any conditions. +-- The @()@ result will not fail any conditions. cegisExceptStdVCMultiInputs :: ( ConfigurableSolver config handle, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, UnionWithExcept t u VerificationConditions (), PlainUnion u, Monad u @@ -922,7 +921,7 @@ -- >>> let [x,c] = ["x","c"] :: [SymInteger] -- >>> import Control.Monad.Except -- >>> :{ --- res :: SymInteger -> ExceptT VerificationConditions UnionM () +-- res :: SymInteger -> ExceptT VerificationConditions Union () -- res x = do -- symAssume $ x .> 0 -- symAssert $ x * c .< 0 @@ -935,16 +934,16 @@ -- translation _ = cegisPostCond (con True) -- :} -- --- >>> cegisExcept (precise z3) x translation res +-- >>> cegisExcept z3 x translation res -- ([...],CEGISSuccess (Model {c -> -1 :: Integer})) cegisExcept :: ( UnionWithExcept t u e v, PlainUnion u, Functor u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, ConfigurableSolver config handle, - SEq inputs + SymEq inputs ) => config -> inputs -> @@ -965,10 +964,10 @@ ( UnionWithExcept t u e v, PlainUnion u, Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, ConfigurableSolver config handle, - SEq inputs + SymEq inputs ) => config -> inputs -> @@ -984,11 +983,11 @@ -- CEGIS for symbolic programs with error handling, using a single symbolic -- input to represent a set of inputs. This function saves the efforts to -- implement the translation function for the standard error type --- 'VerificationConditions', and the standard result type '()'. +-- 'VerificationConditions', and the standard result type @()@. -- -- This function translates assumption violations to failed pre-conditions, -- and translates assertion violations to failed post-conditions. --- The '()' result will not fail any conditions. +-- The @()@ result will not fail any conditions. -- -- The following example tries to find the value of @c@ such that for all -- positive @x@, @x * c < 0 && c > -2@. The @c .> -2@ assertion is used to make @@ -998,23 +997,23 @@ -- >>> let [x,c] = ["x","c"] :: [SymInteger] -- >>> import Control.Monad.Except -- >>> :{ --- res :: SymInteger -> ExceptT VerificationConditions UnionM () +-- res :: SymInteger -> ExceptT VerificationConditions Union () -- res x = do -- symAssume $ x .> 0 -- symAssert $ x * c .< 0 -- symAssert $ c .> -2 -- :} -- --- >>> cegisExceptStdVC (precise z3) x res +-- >>> cegisExceptStdVC z3 x res -- ([...],CEGISSuccess (Model {c -> -1 :: Integer})) cegisExceptStdVC :: ( UnionWithExcept t u VerificationConditions (), PlainUnion u, Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, ConfigurableSolver config handle, - SEq inputs + SymEq inputs ) => config -> inputs -> @@ -1034,10 +1033,10 @@ -- -- >>> :set -XOverloadedStrings -- >>> let [x,c] = ["x","c"] :: [SymInteger] --- >>> cegisForAll (precise z3) x $ cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2) +-- >>> cegisForAll z3 x $ cegisPrePost (x .> 0) (x * c .< 0 .&& c .> -2) -- (...,CEGISSuccess (Model {c -> -1 :: Integer})) cegisForAll :: - ( ExtractSymbolics forallInput, + ( ExtractSym forallInput, ConfigurableSolver config handle ) => config -> @@ -1065,10 +1064,10 @@ ( UnionWithExcept t u e v, PlainUnion u, Functor u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, ConfigurableSolver config handle, - SEq inputs + SymEq inputs ) => config -> inputs -> @@ -1088,10 +1087,10 @@ ( UnionWithExcept t u e v, PlainUnion u, Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, ConfigurableSolver config handle, - SEq inputs + SymEq inputs ) => config -> inputs -> @@ -1111,10 +1110,10 @@ ( UnionWithExcept t u VerificationConditions (), PlainUnion u, Monad u, - EvaluateSym inputs, - ExtractSymbolics inputs, + EvalSym inputs, + ExtractSym inputs, ConfigurableSolver config handle, - SEq inputs + SymEq inputs ) => config -> inputs -> diff --git a/src/Grisette/Internal/Core/Data/Class/Error.hs b/src/Grisette/Internal/Core/Data/Class/Error.hs --- a/src/Grisette/Internal/Core/Data/Class/Error.hs +++ b/src/Grisette/Internal/Core/Data/Class/Error.hs @@ -30,7 +30,7 @@ ( AssertionError (AssertionError), VerificationConditions (AssertionViolation, AssumptionViolation), ) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf) import Grisette.Internal.Core.Data.Class.TryMerge (tryMerge) @@ -82,7 +82,7 @@ -- Terminate the current execution path with the specified error. Compatible -- errors can be transformed. -- --- >>> symThrowTransformableError Overflow :: ExceptT AssertionError UnionM () +-- >>> symThrowTransformableError Overflow :: ExceptT AssertionError Union () -- ExceptT {Left AssertionError} symThrowTransformableError :: ( Mergeable to, @@ -101,8 +101,8 @@ -- Terminate the current execution path with the specified error if the condition does not hold. -- Compatible error can be transformed. -- --- >>> let assert = symAssertTransformableError AssertionError --- >>> assert "a" :: ExceptT AssertionError UnionM () +-- >>> let assert = symAssertTransformableError AssertionError :: SymBool -> ExceptT AssertionError Union () +-- >>> assert "a" -- ExceptT {If (! a) (Left AssertionError) (Right ())} symAssertTransformableError :: ( Mergeable to, @@ -116,6 +116,7 @@ symAssertTransformableError err cond = mrgIf cond (return ()) (symThrowTransformableError err) {-# INLINE symAssertTransformableError #-} +-- | Symbolic assertion with a custom error. symAssertWith :: ( Mergeable e, MonadError e erm, @@ -162,28 +163,28 @@ -- should not be a problem as all paths are terminated and no further evaluation -- would be performed. -- --- >>> symAssert (con False) :: ExceptT AssertionError UnionM () +-- >>> symAssert (con False) :: ExceptT AssertionError Union () -- ExceptT {Left AssertionError} --- >>> do; symAssert (con False); mrgReturn 1 :: ExceptT AssertionError UnionM Integer +-- >>> do; symAssert (con False); mrgReturn 1 :: ExceptT AssertionError Union Integer -- ExceptT -- -- No effect if the condition is true: -- --- >>> symAssert (con True) :: ExceptT AssertionError UnionM () +-- >>> symAssert (con True) :: ExceptT AssertionError Union () -- ExceptT {Right ()} --- >>> do; symAssert (con True); mrgReturn 1 :: ExceptT AssertionError UnionM Integer +-- >>> do; symAssert (con True); mrgReturn 1 :: ExceptT AssertionError Union Integer -- ExceptT {Right 1} -- -- Splitting the path and terminate one of them when the condition is symbolic. -- --- >>> symAssert (ssym "a") :: ExceptT AssertionError UnionM () +-- >>> symAssert (ssym "a") :: ExceptT AssertionError Union () -- ExceptT {If (! a) (Left AssertionError) (Right ())} --- >>> do; symAssert (ssym "a"); mrgReturn 1 :: ExceptT AssertionError UnionM Integer +-- >>> do; symAssert (ssym "a"); mrgReturn 1 :: ExceptT AssertionError Union Integer -- ExceptT {If (! a) (Left AssertionError) (Right 1)} -- -- 'AssertionError' is compatible with 'VerificationConditions': -- --- >>> symAssert (ssym "a") :: ExceptT VerificationConditions UnionM () +-- >>> symAssert (ssym "a") :: ExceptT VerificationConditions Union () -- ExceptT {If (! a) (Left AssertionViolation) (Right ())} symAssert :: (TransformError AssertionError to, Mergeable to, MonadError to erm, MonadUnion erm) => @@ -197,7 +198,7 @@ -- -- /Examples/: -- --- >>> symAssume (ssym "a") :: ExceptT VerificationConditions UnionM () +-- >>> symAssume (ssym "a") :: ExceptT VerificationConditions Union () -- ExceptT {If (! a) (Left AssumptionViolation) (Right ())} symAssume :: (TransformError VerificationConditions to, Mergeable to, MonadError to erm, MonadUnion erm) => diff --git a/src/Grisette/Internal/Core/Data/Class/EvalSym.hs b/src/Grisette/Internal/Core/Data/Class/EvalSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/EvalSym.hs @@ -0,0 +1,631 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.EvalSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.EvalSym + ( -- * Evaluating symbolic values with model + EvalSym (..), + evalSymToCon, + EvalSym1 (..), + evalSym1, + evalSymToCon1, + EvalSym2 (..), + evalSym2, + evalSymToCon2, + + -- * Generic 'EvalSym' + EvalSymArgs (..), + GEvalSym (..), + genericEvalSym, + genericLiftEvalSym, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT), runExceptT) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Maybe (fromJust) +import Data.Monoid (Alt, Ap) +import Data.Ord (Down) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default, unDefault), + Default1 (Default1, unDefault1), + Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Generics.Deriving.Instances () +import qualified Generics.Deriving.Monoid as Monoid +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Class.ToCon + ( ToCon (toCon), + ToCon1, + ToCon2, + toCon1, + toCon2, + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Model (Model, evaluateTerm) +import Grisette.Internal.SymPrim.Prim.Term (LinkedRep, SupportedPrim) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Data.Proxy +-- >>> :set -XTypeApplications + +-- | Evaluating symbolic values with some model. This would substitute the +-- symbols (symbolic constants) with the values in the model. +-- +-- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model +-- >>> evalSym False model ([ssym "a", ssym "b"] :: [SymInteger]) +-- [1,b] +-- +-- If we set the first argument true, the missing symbols will be filled in +-- with some default values: +-- +-- >>> evalSym True model ([ssym "a", ssym "b"] :: [SymInteger]) +-- [1,0] +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving EvalSym via (Default X) +class EvalSym a where + -- | Evaluate a symbolic value with some model, possibly fill in values for + -- the missing symbols. + evalSym :: Bool -> Model -> a -> a + +-- | Evaluate a symbolic value with some model, fill in values for the missing +-- symbols, and convert the result to a concrete value. +-- +-- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model +-- >>> evalSymToCon model ([ssym "a", ssym "b"] :: [SymInteger]) :: [Integer] +-- [1,0] +evalSymToCon :: (ToCon a b, EvalSym a) => Model -> a -> b +evalSymToCon model a = fromJust $ toCon $ evalSym True model a + +-- | Lifting of 'EvalSym' to unary type constructors. +class (forall a. (EvalSym a) => EvalSym (f a)) => EvalSym1 f where + -- | Lift the 'evalSym' function to unary type constructors. + liftEvalSym :: (Bool -> Model -> a -> a) -> (Bool -> Model -> f a -> f a) + +-- | Lifting the standard 'evalSym' to unary type constructors. +evalSym1 :: (EvalSym1 f, EvalSym a) => Bool -> Model -> f a -> f a +evalSym1 = liftEvalSym evalSym +{-# INLINE evalSym1 #-} + +-- | Evaluate and convert to concrete values with lifted standard 'evalSym' for +-- unary type constructors. See 'evalSymToCon'. +evalSymToCon1 :: + (EvalSym1 f, EvalSym a, ToCon1 f g, ToCon a b) => + Model -> + f a -> + g b +evalSymToCon1 model a = fromJust $ toCon1 $ evalSym1 True model a +{-# INLINE evalSymToCon1 #-} + +-- | Lifting of 'EvalSym1' to binary type constructors. +class (forall a. (EvalSym a) => EvalSym1 (f a)) => EvalSym2 f where + -- | Lift the 'evalSym' function to binary type constructors. + liftEvalSym2 :: + (Bool -> Model -> a -> a) -> + (Bool -> Model -> b -> b) -> + (Bool -> Model -> f a b -> f a b) + +-- | Lifting the standard 'evalSym' to binary type constructors. +evalSym2 :: + (EvalSym2 f, EvalSym a, EvalSym b) => + Bool -> + Model -> + f a b -> + f a b +evalSym2 = liftEvalSym2 evalSym evalSym +{-# INLINE evalSym2 #-} + +-- | Evaluate and convert to concrete values with lifted standard 'evalSym' for +-- binary type constructors. See 'evalSymToCon'. +evalSymToCon2 :: + ( EvalSym2 f, + EvalSym a, + EvalSym c, + ToCon2 f g, + ToCon a b, + ToCon c d + ) => + Model -> + f a c -> + g b d +evalSymToCon2 model a = fromJust $ toCon2 $ evalSym2 True model a +{-# INLINE evalSymToCon2 #-} + +-- Derivations + +-- | The arguments to the generic 'evalSym' function. +data family EvalSymArgs arity a :: Type + +data instance EvalSymArgs Arity0 _ = EvalSymArgs0 + +newtype instance EvalSymArgs Arity1 a + = EvalSymArgs1 (Bool -> Model -> a -> a) + +-- | The class of types that can be generically evaluated. +class GEvalSym arity f where + gevalSym :: EvalSymArgs arity a -> Bool -> Model -> f a -> f a + +instance GEvalSym arity V1 where + gevalSym _ _ _ = id + {-# INLINE gevalSym #-} + +instance GEvalSym arity U1 where + gevalSym _ _ _ = id + {-# INLINE gevalSym #-} + +instance + (GEvalSym arity a, GEvalSym arity b) => + GEvalSym arity (a :*: b) + where + gevalSym args fillDefault model (a :*: b) = + gevalSym args fillDefault model a + :*: gevalSym args fillDefault model b + {-# INLINE gevalSym #-} + +instance + (GEvalSym arity a, GEvalSym arity b) => + GEvalSym arity (a :+: b) + where + gevalSym args fillDefault model (L1 l) = + L1 $ gevalSym args fillDefault model l + gevalSym args fillDefault model (R1 r) = + R1 $ gevalSym args fillDefault model r + {-# INLINE gevalSym #-} + +instance (GEvalSym arity a) => GEvalSym arity (M1 i c a) where + gevalSym args fillDefault model (M1 x) = + M1 $ gevalSym args fillDefault model x + {-# INLINE gevalSym #-} + +instance (EvalSym a) => GEvalSym arity (K1 i a) where + gevalSym _ fillDefault model (K1 x) = K1 $ evalSym fillDefault model x + {-# INLINE gevalSym #-} + +instance GEvalSym Arity1 Par1 where + gevalSym (EvalSymArgs1 f) fillDefault model (Par1 x) = + Par1 $ f fillDefault model x + {-# INLINE gevalSym #-} + +instance (EvalSym1 a) => GEvalSym Arity1 (Rec1 a) where + gevalSym (EvalSymArgs1 f) fillDefault model (Rec1 x) = + Rec1 $ liftEvalSym f fillDefault model x + {-# INLINE gevalSym #-} + +instance + (EvalSym1 f, GEvalSym Arity1 g) => + GEvalSym Arity1 (f :.: g) + where + gevalSym targs fillDefault model (Comp1 x) = + Comp1 $ liftEvalSym (gevalSym targs) fillDefault model x + {-# INLINE gevalSym #-} + +-- | Generic 'evalSym' function. +genericEvalSym :: + (Generic a, GEvalSym Arity0 (Rep a)) => Bool -> Model -> a -> a +genericEvalSym fillDefault model = + to . gevalSym EvalSymArgs0 fillDefault model . from +{-# INLINE genericEvalSym #-} + +-- | Generic 'liftEvalSym' function. +genericLiftEvalSym :: + (Generic1 f, GEvalSym Arity1 (Rep1 f)) => + (Bool -> Model -> a -> a) -> + Bool -> + Model -> + f a -> + f a +genericLiftEvalSym f fillDefault model = + to1 . gevalSym (EvalSymArgs1 f) fillDefault model . from1 +{-# INLINE genericLiftEvalSym #-} + +instance + (Generic a, GEvalSym Arity0 (Rep a)) => + EvalSym (Default a) + where + evalSym fillDefault model = + Default . genericEvalSym fillDefault model . unDefault + {-# INLINE evalSym #-} + +instance + (Generic1 f, GEvalSym Arity1 (Rep1 f), EvalSym a) => + EvalSym (Default1 f a) + where + evalSym = evalSym1 + {-# INLINE evalSym #-} + +instance + (Generic1 f, GEvalSym Arity1 (Rep1 f)) => + EvalSym1 (Default1 f) + where + liftEvalSym f fillDefault model = + Default1 . genericLiftEvalSym f fillDefault model . unDefault1 + {-# INLINE liftEvalSym #-} + +#define CONCRETE_EVALUATESYM(type) \ +instance EvalSym type where \ + evalSym _ _ = id + +#define CONCRETE_EVALUATESYM_BV(type) \ +instance (KnownNat n, 1 <= n) => EvalSym (type n) where \ + evalSym _ _ = id + +#if 1 +CONCRETE_EVALUATESYM(Bool) +CONCRETE_EVALUATESYM(Integer) +CONCRETE_EVALUATESYM(Char) +CONCRETE_EVALUATESYM(Int) +CONCRETE_EVALUATESYM(Int8) +CONCRETE_EVALUATESYM(Int16) +CONCRETE_EVALUATESYM(Int32) +CONCRETE_EVALUATESYM(Int64) +CONCRETE_EVALUATESYM(Word) +CONCRETE_EVALUATESYM(Word8) +CONCRETE_EVALUATESYM(Word16) +CONCRETE_EVALUATESYM(Word32) +CONCRETE_EVALUATESYM(Word64) +CONCRETE_EVALUATESYM(Float) +CONCRETE_EVALUATESYM(Double) +CONCRETE_EVALUATESYM(B.ByteString) +CONCRETE_EVALUATESYM(T.Text) +CONCRETE_EVALUATESYM(FPRoundingMode) +CONCRETE_EVALUATESYM(Monoid.All) +CONCRETE_EVALUATESYM(Monoid.Any) +CONCRETE_EVALUATESYM(Ordering) +CONCRETE_EVALUATESYM_BV(IntN) +CONCRETE_EVALUATESYM_BV(WordN) +#endif + +instance (ValidFP eb fb) => EvalSym (FP eb fb) where + evalSym _ _ = id + +-- Symbolic primitives +#define EVALUATE_SYM_SIMPLE(symtype) \ +instance EvalSym symtype where \ + evalSym fillDefault model (symtype t) = \ + symtype $ evaluateTerm fillDefault model t + +#define EVALUATE_SYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => EvalSym (symtype n) where \ + evalSym fillDefault model (symtype t) = \ + symtype $ evaluateTerm fillDefault model t + +#define EVALUATE_SYM_FUN(cop, op, cons) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + EvalSym (op sa sb) where \ + evalSym fillDefault model (cons t) = \ + cons $ evaluateTerm fillDefault model t + +#if 1 +EVALUATE_SYM_SIMPLE(SymBool) +EVALUATE_SYM_SIMPLE(SymInteger) +EVALUATE_SYM_SIMPLE(SymFPRoundingMode) +EVALUATE_SYM_BV(SymIntN) +EVALUATE_SYM_BV(SymWordN) +EVALUATE_SYM_FUN((=->), (=~>), SymTabularFun) +EVALUATE_SYM_FUN((-->), (-~>), SymGeneralFun) +#endif + +instance (ValidFP eb sb) => EvalSym (SymFP eb sb) where + evalSym fillDefault model (SymFP t) = + SymFP $ evaluateTerm fillDefault model t + +-- Instances +deriveBuiltins + (ViaDefault ''EvalSym) + [''EvalSym] + [ ''[], + ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +deriveBuiltins + (ViaDefault1 ''EvalSym1) + [''EvalSym, ''EvalSym1] + [ ''[], + ''Maybe, + ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +-- ExceptT +instance + (EvalSym1 m, EvalSym e, EvalSym a) => + EvalSym (ExceptT e m a) + where + evalSym = evalSym1 + {-# INLINE evalSym #-} + +instance (EvalSym1 m, EvalSym e) => EvalSym1 (ExceptT e m) where + liftEvalSym f fillDefault model = + ExceptT . liftEvalSym (liftEvalSym f) fillDefault model . runExceptT + {-# INLINE liftEvalSym #-} + +-- MaybeT +instance (EvalSym1 m, EvalSym a) => EvalSym (MaybeT m a) where + evalSym = evalSym1 + {-# INLINE evalSym #-} + +instance (EvalSym1 m) => EvalSym1 (MaybeT m) where + liftEvalSym f fillDefault model = + MaybeT . liftEvalSym (liftEvalSym f) fillDefault model . runMaybeT + {-# INLINE liftEvalSym #-} + +-- WriterT +instance + (EvalSym1 m, EvalSym s, EvalSym a) => + EvalSym (WriterLazy.WriterT s m a) + where + evalSym = evalSym1 + {-# INLINE evalSym #-} + +instance + (EvalSym1 m, EvalSym s) => + EvalSym1 (WriterLazy.WriterT s m) + where + liftEvalSym f fillDefault model = + WriterLazy.WriterT + . liftEvalSym (liftEvalSym2 f evalSym) fillDefault model + . WriterLazy.runWriterT + {-# INLINE liftEvalSym #-} + +instance + (EvalSym1 m, EvalSym s, EvalSym a) => + EvalSym (WriterStrict.WriterT s m a) + where + evalSym = evalSym1 + {-# INLINE evalSym #-} + +instance + (EvalSym1 m, EvalSym s) => + EvalSym1 (WriterStrict.WriterT s m) + where + liftEvalSym f fillDefault model = + WriterStrict.WriterT + . liftEvalSym (liftEvalSym2 f evalSym) fillDefault model + . WriterStrict.runWriterT + {-# INLINE liftEvalSym #-} + +-- IdentityT +instance (EvalSym1 m, EvalSym a) => EvalSym (IdentityT m a) where + evalSym = evalSym1 + {-# INLINE evalSym #-} + +instance (EvalSym1 m) => EvalSym1 (IdentityT m) where + liftEvalSym f fillDefault model (IdentityT a) = + IdentityT $ liftEvalSym f fillDefault model a + {-# INLINE liftEvalSym #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (EvalSym (l a), EvalSym (r a)) => EvalSym (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (EvalSym1 l, EvalSym1 r) => EvalSym1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (EvalSym (l a), EvalSym (r a)) => EvalSym (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (EvalSym1 l, EvalSym1 r) => EvalSym1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (EvalSym (f (g a))) => EvalSym (Compose f g a) + +instance (EvalSym1 f, EvalSym1 g) => EvalSym1 (Compose f g) where + liftEvalSym f fillDefault m (Compose l) = + Compose $ liftEvalSym (liftEvalSym f) fillDefault m l + {-# INLINE liftEvalSym #-} + +-- Const +deriving via (Default (Const a b)) instance (EvalSym a) => EvalSym (Const a b) + +deriving via (Default1 (Const a)) instance (EvalSym a) => EvalSym1 (Const a) + +-- Alt +deriving via (Default (Alt f a)) instance (EvalSym (f a)) => EvalSym (Alt f a) + +deriving via (Default1 (Alt f)) instance (EvalSym1 f) => EvalSym1 (Alt f) + +-- Ap +deriving via (Default (Ap f a)) instance (EvalSym (f a)) => EvalSym (Ap f a) + +deriving via (Default1 (Ap f)) instance (EvalSym1 f) => EvalSym1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance EvalSym (U1 p) + +deriving via (Default (V1 p)) instance EvalSym (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (EvalSym c) => EvalSym (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (EvalSym (f p)) => EvalSym (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (EvalSym (f p), EvalSym (g p)) => EvalSym ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (EvalSym (f p), EvalSym (g p)) => EvalSym ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (EvalSym p) => EvalSym (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (EvalSym (f p)) => EvalSym (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (EvalSym (f (g p))) => EvalSym ((f :.: g) p) + +instance EvalSym2 Either where + liftEvalSym2 f _ fillDefault model (Left a) = Left $ f fillDefault model a + liftEvalSym2 _ g fillDefault model (Right a) = + Right $ g fillDefault model a + {-# INLINE liftEvalSym2 #-} + +instance EvalSym2 (,) where + liftEvalSym2 f g fillDefault model (a, b) = + (f fillDefault model a, g fillDefault model b) + {-# INLINE liftEvalSym2 #-} + +instance (EvalSym a) => EvalSym2 ((,,) a) where + liftEvalSym2 f g fillDefault model (a, b, c) = + ( evalSym fillDefault model a, + f fillDefault model b, + g fillDefault model c + ) + {-# INLINE liftEvalSym2 #-} + +instance (EvalSym a, EvalSym b) => EvalSym2 ((,,,) a b) where + liftEvalSym2 f g fillDefault model (a, b, c, d) = + ( evalSym fillDefault model a, + evalSym fillDefault model b, + f fillDefault model c, + g fillDefault model d + ) + {-# INLINE liftEvalSym2 #-} diff --git a/src/Grisette/Internal/Core/Data/Class/EvaluateSym.hs b/src/Grisette/Internal/Core/Data/Class/EvaluateSym.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core/Data/Class/EvaluateSym.hs +++ /dev/null @@ -1,305 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Internal.Core.Data.Class.EvaluateSym --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.Data.Class.EvaluateSym - ( -- * Evaluating symbolic values with model - EvaluateSym (..), - evaluateSymToCon, - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Maybe (fromJust) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Generic (Rep, from, to), - K1 (K1), - M1 (M1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Generics.Deriving.Instances () -import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Internal.Core.Data.Class.ToCon (ToCon (toCon)) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.Prim.Model (Model, evaluateTerm) -import Grisette.Internal.SymPrim.Prim.Term (LinkedRep, SupportedPrim) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP (SymFP (SymFP), SymFPRoundingMode (SymFPRoundingMode)) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> import Data.Proxy --- >>> :set -XTypeApplications - --- | Evaluating symbolic values with some model. --- --- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model --- >>> evaluateSym False model ([ssym "a", ssym "b"] :: [SymInteger]) --- [1,b] --- --- If we set the first argument true, the missing variables will be filled in with --- some default values: --- --- >>> evaluateSym True model ([ssym "a", ssym "b"] :: [SymInteger]) --- [1,0] --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving EvaluateSym via (Default X) -class EvaluateSym a where - -- | Evaluate a symbolic variable with some model, possibly fill in values for the missing variables. - evaluateSym :: Bool -> Model -> a -> a - --- | Evaluate a symbolic variable with some model, fill in values for the missing variables, --- and transform to concrete ones --- --- >>> let model = insertValue "a" (1 :: Integer) emptyModel :: Model --- >>> evaluateSymToCon model ([ssym "a", ssym "b"] :: [SymInteger]) :: [Integer] --- [1,0] -evaluateSymToCon :: (ToCon a b, EvaluateSym a) => Model -> a -> b -evaluateSymToCon model a = fromJust $ toCon $ evaluateSym True model a - --- instances - -#define CONCRETE_EVALUATESYM(type) \ -instance EvaluateSym type where \ - evaluateSym _ _ = id - -#define CONCRETE_EVALUATESYM_BV(type) \ -instance (KnownNat n, 1 <= n) => EvaluateSym (type n) where \ - evaluateSym _ _ = id - -#if 1 -CONCRETE_EVALUATESYM(Bool) -CONCRETE_EVALUATESYM(Integer) -CONCRETE_EVALUATESYM(Char) -CONCRETE_EVALUATESYM(Int) -CONCRETE_EVALUATESYM(Int8) -CONCRETE_EVALUATESYM(Int16) -CONCRETE_EVALUATESYM(Int32) -CONCRETE_EVALUATESYM(Int64) -CONCRETE_EVALUATESYM(Word) -CONCRETE_EVALUATESYM(Word8) -CONCRETE_EVALUATESYM(Word16) -CONCRETE_EVALUATESYM(Word32) -CONCRETE_EVALUATESYM(Word64) -CONCRETE_EVALUATESYM(Float) -CONCRETE_EVALUATESYM(Double) -CONCRETE_EVALUATESYM(B.ByteString) -CONCRETE_EVALUATESYM(T.Text) -CONCRETE_EVALUATESYM(FPRoundingMode) -CONCRETE_EVALUATESYM_BV(IntN) -CONCRETE_EVALUATESYM_BV(WordN) -#endif - -instance (ValidFP eb fb) => EvaluateSym (FP eb fb) where - evaluateSym _ _ = id - --- () -instance EvaluateSym () where - evaluateSym _ _ = id - --- Either -deriving via (Default (Either a b)) instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (Either a b) - --- Maybe -deriving via (Default (Maybe a)) instance (EvaluateSym a) => EvaluateSym (Maybe a) - --- List -deriving via (Default [a]) instance (EvaluateSym a) => EvaluateSym [a] - --- (,) -deriving via (Default (a, b)) instance (EvaluateSym a, EvaluateSym b) => EvaluateSym (a, b) - --- (,,) -deriving via (Default (a, b, c)) instance (EvaluateSym a, EvaluateSym b, EvaluateSym c) => EvaluateSym (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d) => EvaluateSym (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d, EvaluateSym e) => - EvaluateSym (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - (EvaluateSym a, EvaluateSym b, EvaluateSym c, EvaluateSym d, EvaluateSym e, EvaluateSym f) => - EvaluateSym (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( EvaluateSym a, - EvaluateSym b, - EvaluateSym c, - EvaluateSym d, - EvaluateSym e, - EvaluateSym f, - EvaluateSym g - ) => - EvaluateSym (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( EvaluateSym a, - EvaluateSym b, - EvaluateSym c, - EvaluateSym d, - EvaluateSym e, - EvaluateSym f, - EvaluateSym g, - EvaluateSym h - ) => - EvaluateSym ((,,,,,,,) a b c d e f g h) - --- MaybeT -instance (EvaluateSym (m (Maybe a))) => EvaluateSym (MaybeT m a) where - evaluateSym fillDefault model (MaybeT v) = MaybeT $ evaluateSym fillDefault model v - --- ExceptT -instance (EvaluateSym (m (Either e a))) => EvaluateSym (ExceptT e m a) where - evaluateSym fillDefault model (ExceptT v) = ExceptT $ evaluateSym fillDefault model v - --- Sum -deriving via - (Default (Sum f g a)) - instance - (EvaluateSym (f a), EvaluateSym (g a)) => EvaluateSym (Sum f g a) - --- WriterT -instance (EvaluateSym (m (a, s))) => EvaluateSym (WriterLazy.WriterT s m a) where - evaluateSym fillDefault model (WriterLazy.WriterT v) = WriterLazy.WriterT $ evaluateSym fillDefault model v - -instance (EvaluateSym (m (a, s))) => EvaluateSym (WriterStrict.WriterT s m a) where - evaluateSym fillDefault model (WriterStrict.WriterT v) = WriterStrict.WriterT $ evaluateSym fillDefault model v - --- Identity -instance (EvaluateSym a) => EvaluateSym (Identity a) where - evaluateSym fillDefault model (Identity a) = Identity $ evaluateSym fillDefault model a - --- IdentityT -instance (EvaluateSym (m a)) => EvaluateSym (IdentityT m a) where - evaluateSym fillDefault model (IdentityT a) = IdentityT $ evaluateSym fillDefault model a - --- Symbolic primitives -#define EVALUATE_SYM_SIMPLE(symtype) \ -instance EvaluateSym symtype where \ - evaluateSym fillDefault model (symtype t) = symtype $ evaluateTerm fillDefault model t - -#define EVALUATE_SYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => EvaluateSym (symtype n) where \ - evaluateSym fillDefault model (symtype t) = symtype $ evaluateTerm fillDefault model t - -#define EVALUATE_SYM_FUN(cop, op, cons) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - EvaluateSym (op sa sb) where \ - evaluateSym fillDefault model (cons t) = \ - cons $ evaluateTerm fillDefault model t - -#if 1 -EVALUATE_SYM_SIMPLE(SymBool) -EVALUATE_SYM_SIMPLE(SymInteger) -EVALUATE_SYM_SIMPLE(SymFPRoundingMode) -EVALUATE_SYM_BV(SymIntN) -EVALUATE_SYM_BV(SymWordN) -EVALUATE_SYM_FUN((=->), (=~>), SymTabularFun) -EVALUATE_SYM_FUN((-->), (-~>), SymGeneralFun) -#endif - -instance (ValidFP eb sb) => EvaluateSym (SymFP eb sb) where - evaluateSym fillDefault model (SymFP t) = - SymFP $ evaluateTerm fillDefault model t - --- Exception -deriving via (Default AssertionError) instance EvaluateSym AssertionError - -deriving via (Default VerificationConditions) instance EvaluateSym VerificationConditions - -instance (Generic a, EvaluateSym' (Rep a)) => EvaluateSym (Default a) where - evaluateSym fillDefault model = - Default . to . evaluateSym' fillDefault model . from . unDefault - -class EvaluateSym' a where - evaluateSym' :: Bool -> Model -> a c -> a c - -instance EvaluateSym' U1 where - evaluateSym' _ _ = id - {-# INLINE evaluateSym' #-} - -instance EvaluateSym' V1 where - evaluateSym' _ _ = id - {-# INLINE evaluateSym' #-} - -instance (EvaluateSym c) => EvaluateSym' (K1 i c) where - evaluateSym' fillDefault model (K1 v) = K1 $ evaluateSym fillDefault model v - {-# INLINE evaluateSym' #-} - -instance (EvaluateSym' a) => EvaluateSym' (M1 i c a) where - evaluateSym' fillDefault model (M1 v) = M1 $ evaluateSym' fillDefault model v - {-# INLINE evaluateSym' #-} - -instance (EvaluateSym' a, EvaluateSym' b) => EvaluateSym' (a :+: b) where - evaluateSym' fillDefault model (L1 l) = L1 $ evaluateSym' fillDefault model l - evaluateSym' fillDefault model (R1 r) = R1 $ evaluateSym' fillDefault model r - {-# INLINE evaluateSym' #-} - -instance (EvaluateSym' a, EvaluateSym' b) => EvaluateSym' (a :*: b) where - evaluateSym' fillDefault model (a :*: b) = - evaluateSym' fillDefault model a :*: evaluateSym' fillDefault model b - {-# INLINE evaluateSym' #-} diff --git a/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs b/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/ExtractSym.hs @@ -0,0 +1,594 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.ExtractSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.ExtractSym + ( -- * Extracting symbolic constant set from a value + ExtractSym (..), + ExtractSym1 (..), + extractSym1, + ExtractSym2 (..), + extractSym2, + + -- * Generic 'ExtractSym' + ExtractSymArgs (..), + GExtractSym (..), + genericExtractSym, + genericLiftExtractSym, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default, unDefault), + Default1 (Default1, unDefault1), + Generic (Rep, from), + Generic1 (Rep1, from1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + type (:*:) ((:*:)), + type (:+:) (L1, R1), + type (:.:) (Comp1), + ) +import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Model + ( SymbolSet (SymbolSet), + ) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.Prim.TermUtils (extractTerm) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Lib.Base +-- >>> import Data.HashSet as HashSet +-- >>> import Data.List (sort) + +-- | Extracts all the symbols (symbolic constants) that are transitively +-- contained in the given value. +-- +-- >>> extractSym ("a" :: SymBool) :: SymbolSet +-- SymbolSet {a :: Bool} +-- +-- >>> extractSym (mrgIf "a" (mrgReturn ["b"]) (mrgReturn ["c", "d"]) :: Union [SymBool]) :: SymbolSet +-- SymbolSet {a :: Bool, b :: Bool, c :: Bool, d :: Bool} +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving ExtractSym via (Default X) +class ExtractSym a where + extractSym :: a -> SymbolSet + +-- | Lifting of 'ExtractSym' to unary type constructors. +class + (forall a. (ExtractSym a) => ExtractSym (f a)) => + ExtractSym1 f + where + -- | Lifts the 'extractSym' function to unary type constructors. + liftExtractSym :: (a -> SymbolSet) -> f a -> SymbolSet + +-- | Lift the standard 'extractSym' to unary type constructors. +extractSym1 :: (ExtractSym1 f, ExtractSym a) => f a -> SymbolSet +extractSym1 = liftExtractSym extractSym +{-# INLINE extractSym1 #-} + +-- | Lifting of 'ExtractSym' to binary type constructors. +class + (forall a. (ExtractSym a) => ExtractSym1 (f a)) => + ExtractSym2 f + where + -- | Lifts the 'extractSym' function to binary type constructors. + liftExtractSym2 :: + (a -> SymbolSet) -> (b -> SymbolSet) -> f a b -> SymbolSet + +-- | Lift the standard 'extractSym' to binary type constructors. +extractSym2 :: + (ExtractSym2 f, ExtractSym a, ExtractSym b) => + f a b -> + SymbolSet +extractSym2 = liftExtractSym2 extractSym extractSym +{-# INLINE extractSym2 #-} + +-- Derivations + +-- | The arguments to the generic 'extractSym' function. +data family ExtractSymArgs arity a :: Type + +data instance ExtractSymArgs Arity0 _ = ExtractSymArgs0 + +newtype instance ExtractSymArgs Arity1 a + = ExtractSymArgs1 (a -> SymbolSet) + +-- | The class of types that can generically extract the symbols. +class GExtractSym arity f where + gextractSym :: ExtractSymArgs arity a -> f a -> SymbolSet + +instance GExtractSym arity V1 where + gextractSym _ _ = mempty + {-# INLINE gextractSym #-} + +instance GExtractSym arity U1 where + gextractSym _ _ = mempty + {-# INLINE gextractSym #-} + +instance (GExtractSym arity a) => GExtractSym arity (M1 i c a) where + gextractSym args (M1 x) = gextractSym args x + {-# INLINE gextractSym #-} + +instance (ExtractSym a) => GExtractSym arity (K1 i a) where + gextractSym _ (K1 x) = extractSym x + {-# INLINE gextractSym #-} + +instance + (GExtractSym arity a, GExtractSym arity b) => + GExtractSym arity (a :+: b) + where + gextractSym args (L1 x) = gextractSym args x + gextractSym args (R1 x) = gextractSym args x + {-# INLINE gextractSym #-} + +instance + (GExtractSym arity a, GExtractSym arity b) => + GExtractSym arity (a :*: b) + where + gextractSym args (x :*: y) = + gextractSym args x <> gextractSym args y + {-# INLINE gextractSym #-} + +instance GExtractSym Arity1 Par1 where + gextractSym (ExtractSymArgs1 f) (Par1 x) = f x + {-# INLINE gextractSym #-} + +instance (ExtractSym1 a) => GExtractSym Arity1 (Rec1 a) where + gextractSym (ExtractSymArgs1 f) (Rec1 x) = + liftExtractSym f x + {-# INLINE gextractSym #-} + +instance + (ExtractSym1 f, GExtractSym Arity1 g) => + GExtractSym Arity1 (f :.: g) + where + gextractSym targs (Comp1 x) = + liftExtractSym (gextractSym targs) x + {-# INLINE gextractSym #-} + +-- | Generic 'extractSym' function. +genericExtractSym :: + (Generic a, GExtractSym Arity0 (Rep a)) => + a -> + SymbolSet +genericExtractSym = gextractSym ExtractSymArgs0 . from + +-- | Generic 'liftExtractSym' function. +genericLiftExtractSym :: + (Generic1 f, GExtractSym Arity1 (Rep1 f)) => + (a -> SymbolSet) -> + f a -> + SymbolSet +genericLiftExtractSym f = + gextractSym (ExtractSymArgs1 f) . from1 + +instance + (Generic a, GExtractSym Arity0 (Rep a)) => + ExtractSym (Default a) + where + extractSym = genericExtractSym . unDefault + {-# INLINE extractSym #-} + +instance + (Generic1 f, GExtractSym Arity1 (Rep1 f), ExtractSym a) => + ExtractSym (Default1 f a) + where + extractSym = extractSym1 + {-# INLINE extractSym #-} + +instance + (Generic1 f, GExtractSym Arity1 (Rep1 f)) => + ExtractSym1 (Default1 f) + where + liftExtractSym f = genericLiftExtractSym f . unDefault1 + {-# INLINE liftExtractSym #-} + +#define CONCRETE_EXTRACT_SYMBOLICS(type) \ +instance ExtractSym type where \ + extractSym _ = mempty + +#define CONCRETE_EXTRACT_SYMBOLICS_BV(type) \ +instance (KnownNat n, 1 <= n) => ExtractSym (type n) where \ + extractSym _ = mempty + +#if 1 +CONCRETE_EXTRACT_SYMBOLICS(Bool) +CONCRETE_EXTRACT_SYMBOLICS(Integer) +CONCRETE_EXTRACT_SYMBOLICS(Char) +CONCRETE_EXTRACT_SYMBOLICS(Int) +CONCRETE_EXTRACT_SYMBOLICS(Int8) +CONCRETE_EXTRACT_SYMBOLICS(Int16) +CONCRETE_EXTRACT_SYMBOLICS(Int32) +CONCRETE_EXTRACT_SYMBOLICS(Int64) +CONCRETE_EXTRACT_SYMBOLICS(Word) +CONCRETE_EXTRACT_SYMBOLICS(Word8) +CONCRETE_EXTRACT_SYMBOLICS(Word16) +CONCRETE_EXTRACT_SYMBOLICS(Word32) +CONCRETE_EXTRACT_SYMBOLICS(Word64) +CONCRETE_EXTRACT_SYMBOLICS(Float) +CONCRETE_EXTRACT_SYMBOLICS(Double) +CONCRETE_EXTRACT_SYMBOLICS(B.ByteString) +CONCRETE_EXTRACT_SYMBOLICS(T.Text) +CONCRETE_EXTRACT_SYMBOLICS(FPRoundingMode) +CONCRETE_EXTRACT_SYMBOLICS(Monoid.All) +CONCRETE_EXTRACT_SYMBOLICS(Monoid.Any) +CONCRETE_EXTRACT_SYMBOLICS(Ordering) +CONCRETE_EXTRACT_SYMBOLICS_BV(WordN) +CONCRETE_EXTRACT_SYMBOLICS_BV(IntN) +#endif + +instance (ValidFP eb sb) => ExtractSym (FP eb sb) where + extractSym _ = mempty + +#define EXTRACT_SYMBOLICS_SIMPLE(symtype) \ +instance ExtractSym symtype where \ + extractSym (symtype t) = SymbolSet $ extractTerm t + +#define EXTRACT_SYMBOLICS_BV(symtype) \ +instance (KnownNat n, 1 <= n) => ExtractSym (symtype n) where \ + extractSym (symtype t) = SymbolSet $ extractTerm t + +#define EXTRACT_SYMBOLICS_FUN(cop, op, cons) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + ExtractSym (op sa sb) where \ + extractSym (cons t) = SymbolSet $ extractTerm t + +#if 1 +EXTRACT_SYMBOLICS_SIMPLE(SymBool) +EXTRACT_SYMBOLICS_SIMPLE(SymInteger) +EXTRACT_SYMBOLICS_SIMPLE(SymFPRoundingMode) +EXTRACT_SYMBOLICS_BV(SymIntN) +EXTRACT_SYMBOLICS_BV(SymWordN) +EXTRACT_SYMBOLICS_FUN((=->), (=~>), SymTabularFun) +EXTRACT_SYMBOLICS_FUN((-->), (-~>), SymGeneralFun) +#endif + +instance (ValidFP eb fb) => ExtractSym (SymFP eb fb) where + extractSym (SymFP t) = SymbolSet $ extractTerm t + +-- Instances +deriveBuiltins + (ViaDefault ''ExtractSym) + [''ExtractSym] + [ ''[], + ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +deriveBuiltins + (ViaDefault1 ''ExtractSym1) + [''ExtractSym, ''ExtractSym1] + [ ''[], + ''Maybe, + ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +-- ExceptT +instance + (ExtractSym1 m, ExtractSym e, ExtractSym a) => + ExtractSym (ExceptT e m a) + where + extractSym = extractSym1 + {-# INLINE extractSym #-} + +instance + (ExtractSym1 m, ExtractSym e) => + ExtractSym1 (ExceptT e m) + where + liftExtractSym f (ExceptT v) = + liftExtractSym (liftExtractSym f) v + {-# INLINE liftExtractSym #-} + +-- MaybeT +instance + (ExtractSym1 m, ExtractSym a) => + ExtractSym (MaybeT m a) + where + extractSym = extractSym1 + {-# INLINE extractSym #-} + +instance + (ExtractSym1 m) => + ExtractSym1 (MaybeT m) + where + liftExtractSym f (MaybeT v) = + liftExtractSym (liftExtractSym f) v + {-# INLINE liftExtractSym #-} + +-- WriterT +instance + (ExtractSym1 m, ExtractSym w, ExtractSym a) => + ExtractSym (WriterLazy.WriterT w m a) + where + extractSym = extractSym1 + {-# INLINE extractSym #-} + +instance + (ExtractSym1 m, ExtractSym w) => + ExtractSym1 (WriterLazy.WriterT w m) + where + liftExtractSym f (WriterLazy.WriterT v) = + liftExtractSym (liftExtractSym2 f extractSym) v + {-# INLINE liftExtractSym #-} + +instance + (ExtractSym1 m, ExtractSym w, ExtractSym a) => + ExtractSym (WriterStrict.WriterT w m a) + where + extractSym = extractSym1 + {-# INLINE extractSym #-} + +instance + (ExtractSym1 m, ExtractSym w) => + ExtractSym1 (WriterStrict.WriterT w m) + where + liftExtractSym f (WriterStrict.WriterT v) = + liftExtractSym (liftExtractSym2 f extractSym) v + {-# INLINE liftExtractSym #-} + +-- IdentityT +instance + (ExtractSym1 m, ExtractSym a) => + ExtractSym (IdentityT m a) + where + extractSym = extractSym1 + {-# INLINE extractSym #-} + +instance (ExtractSym1 m) => ExtractSym1 (IdentityT m) where + liftExtractSym f (IdentityT v) = liftExtractSym f v + {-# INLINE liftExtractSym #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (ExtractSym (l a), ExtractSym (r a)) => + ExtractSym (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (ExtractSym1 l, ExtractSym1 r) => + ExtractSym1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (ExtractSym (l a), ExtractSym (r a)) => + ExtractSym (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (ExtractSym1 l, ExtractSym1 r) => ExtractSym1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (ExtractSym (f (g a))) => ExtractSym (Compose f g a) + +instance + (ExtractSym1 f, ExtractSym1 g) => + ExtractSym1 (Compose f g) + where + liftExtractSym f (Compose l) = + liftExtractSym (liftExtractSym f) l + {-# INLINE liftExtractSym #-} + +-- Const +deriving via + (Default (Const a b)) + instance + (ExtractSym a) => ExtractSym (Const a b) + +deriving via + (Default1 (Const a)) + instance + (ExtractSym a) => ExtractSym1 (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (ExtractSym (f a)) => ExtractSym (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (ExtractSym1 f) => ExtractSym1 (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (ExtractSym (f a)) => ExtractSym (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (ExtractSym1 f) => ExtractSym1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance ExtractSym (U1 p) + +deriving via (Default (V1 p)) instance ExtractSym (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (ExtractSym c) => ExtractSym (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (ExtractSym (f p)) => ExtractSym (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (ExtractSym (f p), ExtractSym (g p)) => + ExtractSym ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (ExtractSym (f p), ExtractSym (g p)) => + ExtractSym ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (ExtractSym p) => ExtractSym (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (ExtractSym (f p)) => ExtractSym (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (ExtractSym (f (g p))) => ExtractSym ((f :.: g) p) + +-- ExtractSym2 +instance ExtractSym2 Either where + liftExtractSym2 f _ (Left x) = f x + liftExtractSym2 _ g (Right y) = g y + {-# INLINE liftExtractSym2 #-} + +instance ExtractSym2 (,) where + liftExtractSym2 f g (x, y) = f x <> g y + {-# INLINE liftExtractSym2 #-} + +instance (ExtractSym a) => ExtractSym2 ((,,) a) where + liftExtractSym2 f g (x, y, z) = extractSym x <> f y <> g z + {-# INLINE liftExtractSym2 #-} + +instance + (ExtractSym a, ExtractSym b) => + ExtractSym2 ((,,,) a b) + where + liftExtractSym2 f g (x, y, z, w) = + extractSym x <> extractSym y <> f z <> g w + {-# INLINE liftExtractSym2 #-} diff --git a/src/Grisette/Internal/Core/Data/Class/ExtractSymbolics.hs b/src/Grisette/Internal/Core/Data/Class/ExtractSymbolics.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core/Data/Class/ExtractSymbolics.hs +++ /dev/null @@ -1,335 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Internal.Core.Data.Class.ExtractSymbolics --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.Data.Class.ExtractSymbolics - ( -- * Extracting symbolic constant set from a value - ExtractSymbolics (..), - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Generic (Rep, from), - K1 (unK1), - M1 (unM1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.Prim.Model - ( SymbolSet (SymbolSet), - ) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedPrim, - ) -import Grisette.Internal.SymPrim.Prim.TermUtils (extractSymbolicsTerm) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> import Grisette.Lib.Base --- >>> import Data.HashSet as HashSet --- >>> import Data.List (sort) - --- | Extracts all the symbolic variables that are transitively contained in the given value. --- --- >>> extractSymbolics ("a" :: SymBool) :: SymbolSet --- SymbolSet {a :: Bool} --- --- >>> extractSymbolics (mrgIf "a" (mrgReturn ["b"]) (mrgReturn ["c", "d"]) :: UnionM [SymBool]) :: SymbolSet --- SymbolSet {a :: Bool, b :: Bool, c :: Bool, d :: Bool} --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving ExtractSymbolics via (Default X) -class ExtractSymbolics a where - extractSymbolics :: a -> SymbolSet - --- instances -#define CONCRETE_EXTRACT_SYMBOLICS(type) \ -instance ExtractSymbolics type where \ - extractSymbolics _ = mempty - -#define CONCRETE_EXTRACT_SYMBOLICS_BV(type) \ -instance (KnownNat n, 1 <= n) => ExtractSymbolics (type n) where \ - extractSymbolics _ = mempty - -#if 1 -CONCRETE_EXTRACT_SYMBOLICS(Bool) -CONCRETE_EXTRACT_SYMBOLICS(Integer) -CONCRETE_EXTRACT_SYMBOLICS(Char) -CONCRETE_EXTRACT_SYMBOLICS(Int) -CONCRETE_EXTRACT_SYMBOLICS(Int8) -CONCRETE_EXTRACT_SYMBOLICS(Int16) -CONCRETE_EXTRACT_SYMBOLICS(Int32) -CONCRETE_EXTRACT_SYMBOLICS(Int64) -CONCRETE_EXTRACT_SYMBOLICS(Word) -CONCRETE_EXTRACT_SYMBOLICS(Word8) -CONCRETE_EXTRACT_SYMBOLICS(Word16) -CONCRETE_EXTRACT_SYMBOLICS(Word32) -CONCRETE_EXTRACT_SYMBOLICS(Word64) -CONCRETE_EXTRACT_SYMBOLICS(Float) -CONCRETE_EXTRACT_SYMBOLICS(Double) -CONCRETE_EXTRACT_SYMBOLICS(B.ByteString) -CONCRETE_EXTRACT_SYMBOLICS(T.Text) -CONCRETE_EXTRACT_SYMBOLICS(FPRoundingMode) -CONCRETE_EXTRACT_SYMBOLICS_BV(WordN) -CONCRETE_EXTRACT_SYMBOLICS_BV(IntN) -#endif - -instance (ValidFP eb sb) => ExtractSymbolics (FP eb sb) where - extractSymbolics _ = mempty - --- () -instance ExtractSymbolics () where - extractSymbolics _ = mempty - --- Either -deriving via - (Default (Either a b)) - instance - (ExtractSymbolics a, ExtractSymbolics b) => - ExtractSymbolics (Either a b) - --- Maybe -deriving via - (Default (Maybe a)) - instance - (ExtractSymbolics a) => ExtractSymbolics (Maybe a) - --- List -deriving via - (Default [a]) - instance - (ExtractSymbolics a) => ExtractSymbolics [a] - --- (,) -deriving via - (Default (a, b)) - instance - (ExtractSymbolics a, ExtractSymbolics b) => - ExtractSymbolics (a, b) - --- (,,) -deriving via - (Default (a, b, c)) - instance - (ExtractSymbolics a, ExtractSymbolics b, ExtractSymbolics c) => - ExtractSymbolics (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d - ) => - ExtractSymbolics (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d, - ExtractSymbolics e - ) => - ExtractSymbolics (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d, - ExtractSymbolics e, - ExtractSymbolics f - ) => - ExtractSymbolics (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d, - ExtractSymbolics e, - ExtractSymbolics f, - ExtractSymbolics g - ) => - ExtractSymbolics (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( ExtractSymbolics a, - ExtractSymbolics b, - ExtractSymbolics c, - ExtractSymbolics d, - ExtractSymbolics e, - ExtractSymbolics f, - ExtractSymbolics g, - ExtractSymbolics h - ) => - ExtractSymbolics (a, b, c, d, e, f, g, h) - --- MaybeT -instance (ExtractSymbolics (m (Maybe a))) => ExtractSymbolics (MaybeT m a) where - extractSymbolics (MaybeT v) = extractSymbolics v - --- ExceptT -instance - (ExtractSymbolics (m (Either e a))) => - ExtractSymbolics (ExceptT e m a) - where - extractSymbolics (ExceptT v) = extractSymbolics v - --- Sum -deriving via - (Default (Sum f g a)) - instance - (ExtractSymbolics (f a), ExtractSymbolics (g a)) => - ExtractSymbolics (Sum f g a) - --- WriterT -instance - (ExtractSymbolics (m (a, s))) => - ExtractSymbolics (WriterLazy.WriterT s m a) - where - extractSymbolics (WriterLazy.WriterT f) = extractSymbolics f - -instance - (ExtractSymbolics (m (a, s))) => - ExtractSymbolics (WriterStrict.WriterT s m a) - where - extractSymbolics (WriterStrict.WriterT f) = extractSymbolics f - --- Identity -instance (ExtractSymbolics a) => ExtractSymbolics (Identity a) where - extractSymbolics (Identity a) = extractSymbolics a - --- IdentityT -instance (ExtractSymbolics (m a)) => ExtractSymbolics (IdentityT m a) where - extractSymbolics (IdentityT a) = extractSymbolics a - -#define EXTRACT_SYMBOLICS_SIMPLE(symtype) \ -instance ExtractSymbolics symtype where \ - extractSymbolics (symtype t) = SymbolSet $ extractSymbolicsTerm t - -#define EXTRACT_SYMBOLICS_BV(symtype) \ -instance (KnownNat n, 1 <= n) => ExtractSymbolics (symtype n) where \ - extractSymbolics (symtype t) = SymbolSet $ extractSymbolicsTerm t - -#define EXTRACT_SYMBOLICS_FUN(cop, op, cons) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - ExtractSymbolics (op sa sb) where \ - extractSymbolics (cons t) = SymbolSet $ extractSymbolicsTerm t - -#if 1 -EXTRACT_SYMBOLICS_SIMPLE(SymBool) -EXTRACT_SYMBOLICS_SIMPLE(SymInteger) -EXTRACT_SYMBOLICS_SIMPLE(SymFPRoundingMode) -EXTRACT_SYMBOLICS_BV(SymIntN) -EXTRACT_SYMBOLICS_BV(SymWordN) -EXTRACT_SYMBOLICS_FUN((=->), (=~>), SymTabularFun) -EXTRACT_SYMBOLICS_FUN((-->), (-~>), SymGeneralFun) -#endif - -instance (ValidFP eb fb) => ExtractSymbolics (SymFP eb fb) where - extractSymbolics (SymFP t) = SymbolSet $ extractSymbolicsTerm t - --- Exception -deriving via (Default AssertionError) instance ExtractSymbolics AssertionError - -deriving via (Default VerificationConditions) instance ExtractSymbolics VerificationConditions - -instance (Generic a, ExtractSymbolics' (Rep a)) => ExtractSymbolics (Default a) where - extractSymbolics = extractSymbolics' . from . unDefault - -class ExtractSymbolics' a where - extractSymbolics' :: a c -> SymbolSet - -instance ExtractSymbolics' U1 where - extractSymbolics' _ = mempty - -instance ExtractSymbolics' V1 where - extractSymbolics' _ = mempty - -instance (ExtractSymbolics c) => ExtractSymbolics' (K1 i c) where - extractSymbolics' = extractSymbolics . unK1 - -instance (ExtractSymbolics' a) => ExtractSymbolics' (M1 i c a) where - extractSymbolics' = extractSymbolics' . unM1 - -instance - (ExtractSymbolics' a, ExtractSymbolics' b) => - ExtractSymbolics' (a :+: b) - where - extractSymbolics' (L1 l) = extractSymbolics' l - extractSymbolics' (R1 r) = extractSymbolics' r - -instance - (ExtractSymbolics' a, ExtractSymbolics' b) => - ExtractSymbolics' (a :*: b) - where - extractSymbolics' (l :*: r) = extractSymbolics' l <> extractSymbolics' r diff --git a/src/Grisette/Internal/Core/Data/Class/GPretty.hs b/src/Grisette/Internal/Core/Data/Class/GPretty.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core/Data/Class/GPretty.hs +++ /dev/null @@ -1,451 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - -module Grisette.Internal.Core.Data.Class.GPretty - ( GPretty (..), - groupedEnclose, - condEnclose, - prettyWithConstructor, - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as C -import Data.Functor.Sum (Sum) -import qualified Data.HashMap.Lazy as HM -import qualified Data.HashSet as HS -import Data.Int (Int16, Int32, Int64, Int8) -import Data.String (IsString (fromString)) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics - ( C, - C1, - Constructor (conFixity, conIsRecord, conName), - D, - Fixity (Infix, Prefix), - Generic (Rep, from), - K1 (K1), - M1 (M1), - S, - Selector (selName), - U1 (U1), - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import GHC.TypeLits (KnownNat, type (<=)) -import Generics.Deriving (Default (Default, unDefault)) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedPrim, - prettyPrintTerm, - ) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) - -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter - ( (<+>), - align, - encloseSep, - flatAlt, - group, - nest, - vcat, - viaShow, - vsep, - Doc, - Pretty(pretty), - ) -#else -import Data.Text.Prettyprint.Doc - ( (<+>), - align, - encloseSep, - flatAlt, - group, - nest, - vcat, - viaShow, - vsep, - Doc, - Pretty(pretty), - ) -#endif - -glist :: [Doc ann] -> Doc ann -glist l - | null l = "[]" - | length l == 1 = "[" <> head l <> "]" - | otherwise = groupedEnclose "[" "]" $ encloseSep "" "" (flatAlt ", " ",") l - -class GPretty a where - gpretty :: a -> Doc ann - gprettyPrec :: Int -> a -> Doc ann - gprettyList :: [a] -> Doc ann - gprettyList = align . glist . map gpretty - - gpretty = gprettyPrec 0 - gprettyPrec _ = gpretty - - {-# MINIMAL gpretty | gprettyPrec #-} - -#define GPRETTY_SIMPLE(type) \ -instance GPretty type where gprettyPrec = viaShowsPrec showsPrec - -instance GPretty Char where - gpretty = viaShow - gprettyList v = pretty (fromString v :: T.Text) - -#if 1 -GPRETTY_SIMPLE(Bool) -GPRETTY_SIMPLE(Integer) -GPRETTY_SIMPLE(Int) -GPRETTY_SIMPLE(Int8) -GPRETTY_SIMPLE(Int16) -GPRETTY_SIMPLE(Int32) -GPRETTY_SIMPLE(Int64) -GPRETTY_SIMPLE(Word) -GPRETTY_SIMPLE(Word8) -GPRETTY_SIMPLE(Word16) -GPRETTY_SIMPLE(Word32) -GPRETTY_SIMPLE(Word64) -GPRETTY_SIMPLE(Float) -GPRETTY_SIMPLE(Double) -GPRETTY_SIMPLE(FPRoundingMode) -#endif - -instance GPretty B.ByteString where - gpretty = pretty . C.unpack - -instance GPretty T.Text where - gpretty = pretty - -instance (KnownNat n, 1 <= n) => GPretty (IntN n) where - gpretty = viaShow - -instance (KnownNat n, 1 <= n) => GPretty (WordN n) where - gpretty = viaShow - -instance (ValidFP eb sb) => GPretty (FP eb sb) where - gpretty = viaShow - --- () -instance GPretty () where - gpretty = viaShow - --- Either -deriving via - (Default (Either a b)) - instance - (GPretty a, GPretty b) => GPretty (Either a b) - --- Maybe -deriving via - (Default (Maybe a)) - instance - (GPretty a) => GPretty (Maybe a) - --- List -instance (GPretty a) => GPretty [a] where - gpretty = gprettyList - --- (,) -deriving via - (Default (a, b)) - instance - (GPretty a, GPretty b) => GPretty (a, b) - --- (,,) -deriving via - (Default (a, b, c)) - instance - (GPretty a, GPretty b, GPretty c) => GPretty (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d - ) => - GPretty (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d, - GPretty e - ) => - GPretty (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d, - GPretty e, - GPretty f - ) => - GPretty (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d, - GPretty e, - GPretty f, - GPretty g - ) => - GPretty (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( GPretty a, - GPretty b, - GPretty c, - GPretty d, - GPretty e, - GPretty f, - GPretty g, - GPretty h - ) => - GPretty (a, b, c, d, e, f, g, h) - --- Sum -deriving via - (Default (Sum f g a)) - instance - (GPretty (f a), GPretty (g a)) => - GPretty (Sum f g a) - --- MaybeT -instance - (GPretty (m (Maybe a))) => - GPretty (MaybeT m a) - where - gprettyPrec n (MaybeT a) = prettyWithConstructor n "MaybeT" [gprettyPrec 11 a] - --- ExceptT -instance - (GPretty (m (Either e a))) => - GPretty (ExceptT e m a) - where - gprettyPrec n (ExceptT a) = - prettyWithConstructor n "ExceptT" [gprettyPrec 11 a] - --- WriterT -instance - (GPretty (m (a, w))) => - GPretty (WriterLazy.WriterT w m a) - where - gprettyPrec n (WriterLazy.WriterT a) = - prettyWithConstructor n "WriterT" [gprettyPrec 11 a] - -instance - (GPretty (m (a, w))) => - GPretty (WriterStrict.WriterT w m a) - where - gprettyPrec n (WriterStrict.WriterT a) = - prettyWithConstructor n "WriterT" [gprettyPrec 11 a] - --- Identity -instance (GPretty a) => GPretty (Identity a) where - gprettyPrec n (Identity a) = - prettyWithConstructor n "Identity" [gprettyPrec 11 a] - --- IdentityT -instance (GPretty (m a)) => GPretty (IdentityT m a) where - gprettyPrec n (IdentityT a) = - prettyWithConstructor n "IdentityT" [gprettyPrec 11 a] - --- Prettyprint -#define GPRETTY_SYM_SIMPLE(symtype) \ -instance GPretty symtype where \ - gpretty (symtype t) = prettyPrintTerm t - -#define GPRETTY_SYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => GPretty (symtype n) where \ - gpretty (symtype t) = prettyPrintTerm t - -#define GPRETTY_SYM_FUN(op, cons) \ -instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb)\ - => GPretty (sa op sb) where \ - gpretty (cons t) = prettyPrintTerm t - -#if 1 -GPRETTY_SYM_SIMPLE(SymBool) -GPRETTY_SYM_SIMPLE(SymInteger) -GPRETTY_SYM_SIMPLE(SymFPRoundingMode) -GPRETTY_SYM_BV(SymIntN) -GPRETTY_SYM_BV(SymWordN) -GPRETTY_SYM_FUN(=~>, SymTabularFun) -GPRETTY_SYM_FUN(-~>, SymGeneralFun) -#endif - -instance (ValidFP eb sb) => GPretty (SymFP eb sb) where - gpretty (SymFP t) = prettyPrintTerm t - -instance (GPretty a) => GPretty (HS.HashSet a) where - gprettyPrec n s = - prettyWithConstructor n "fromList" [gprettyPrec 11 $ HS.toList s] - -instance (GPretty k, GPretty v) => GPretty (HM.HashMap k v) where - gprettyPrec n s = - prettyWithConstructor n "fromList" [gprettyPrec 11 $ HM.toList s] - -instance (Generic a, GPretty' (Rep a)) => GPretty (Default a) where - gprettyPrec i v = gprettyPrec' Pref i $ from $ unDefault v - -data Type = Rec | Tup | Pref | Inf String Int - -class GPretty' a where - gprettyPrec' :: Type -> Int -> a c -> Doc ann - isNullary :: a c -> Bool - isNullary = error "generic gpretty (isNullary): unnecessary case" - -instance GPretty' V1 where - gprettyPrec' _ _ x = case x of {} - -instance GPretty' U1 where - gprettyPrec' _ _ U1 = "" - isNullary _ = True - -instance (GPretty c) => GPretty' (K1 i c) where - gprettyPrec' _ n (K1 a) = gprettyPrec n a - isNullary _ = False - -groupedEnclose :: Doc ann -> Doc ann -> Doc ann -> Doc ann -groupedEnclose l r d = group $ align $ vcat [l <> flatAlt " " "" <> d, r] - -condEnclose :: Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann -condEnclose b = if b then groupedEnclose else const $ const id - -prettyWithConstructor :: Int -> Doc ann -> [Doc ann] -> Doc ann -prettyWithConstructor n c l = - group $ condEnclose (n > 10) "(" ")" $ align $ nest 2 $ vsep (c : l) - -instance (GPretty' a, Constructor c) => GPretty' (M1 C c a) where - gprettyPrec' _ n c@(M1 x) = - case t of - Tup -> - prettyBraces t (gprettyPrec' t 0 x) - Inf _ m -> - group $ condEnclose (n > m) "(" ")" $ gprettyPrec' t m x - _ -> - if isNullary x - then gpretty (conName c) - else - prettyWithConstructor - n - (gpretty (conName c)) - [prettyBraces t (gprettyPrec' t 11 x)] - where - prettyBraces :: Type -> Doc ann -> Doc ann - prettyBraces Rec = groupedEnclose "{" "}" - prettyBraces Tup = groupedEnclose "(" ")" - prettyBraces Pref = id - prettyBraces (Inf _ _) = id - fixity = conFixity c - t - | conIsRecord c = Rec - | conIsTuple c = Tup - | otherwise = case fixity of - Prefix -> Pref - Infix _ i -> Inf (conName c) i - conIsTuple :: C1 c f p -> Bool - conIsTuple y = tupleName (conName y) - where - tupleName ('(' : ',' : _) = True - tupleName _ = False - -instance (Selector s, GPretty' a) => GPretty' (M1 S s a) where - gprettyPrec' t n s@(M1 x) - | selName s == "" = - case t of - Pref -> gprettyPrec' t (n + 1) x - _ -> gprettyPrec' t (n + 1) x - | otherwise = - pretty (selName s) <+> "=" <+> gprettyPrec' t 0 x - isNullary (M1 x) = isNullary x - -instance (GPretty' a) => GPretty' (M1 D d a) where - gprettyPrec' t n (M1 x) = gprettyPrec' t n x - -instance (GPretty' a, GPretty' b) => GPretty' (a :+: b) where - gprettyPrec' t n (L1 x) = gprettyPrec' t n x - gprettyPrec' t n (R1 x) = gprettyPrec' t n x - -instance (GPretty' a, GPretty' b) => GPretty' (a :*: b) where - gprettyPrec' t@Rec n (a :*: b) = - vcat - [ gprettyPrec' t n a, - "," <+> gprettyPrec' t n b - ] - gprettyPrec' t@(Inf s _) n (a :*: b) = - align $ - nest 2 $ - vsep - [ gprettyPrec' t n a, - pretty s <+> gprettyPrec' t n b - ] - gprettyPrec' t@Tup _ (a :*: b) = - vcat - [ gprettyPrec' t 0 a, - "," <> flatAlt " " "" <> gprettyPrec' t 0 b - ] - gprettyPrec' t@Pref n (a :*: b) = - vsep - [ gprettyPrec' t (n + 1) a, - gprettyPrec' t (n + 1) b - ] - isNullary _ = False - -viaShowsPrec :: (Int -> a -> ShowS) -> Int -> a -> Doc ann -viaShowsPrec f n a = pretty (f n a "") diff --git a/src/Grisette/Internal/Core/Data/Class/GenSym.hs b/src/Grisette/Internal/Core/Data/Class/GenSym.hs --- a/src/Grisette/Internal/Core/Data/Class/GenSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/GenSym.hs @@ -104,7 +104,11 @@ type (:*:) ((:*:)), type (:+:) (L1, R1), ) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, isMerged, underlyingUnion) +import Grisette.Internal.Core.Control.Monad.Union + ( Union, + isMerged, + unionBase, + ) import Grisette.Internal.Core.Data.Class.Mergeable ( Mergeable (rootStrategy), Mergeable1 (liftRootStrategy), @@ -116,7 +120,7 @@ import Grisette.Internal.Core.Data.Class.SimpleMergeable ( SimpleMergeable (mrgIte), SimpleMergeable1 (liftMrgIte), - UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), + SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), mrgIf, ) import Grisette.Internal.Core.Data.Class.Solvable (Solvable (isym)) @@ -126,7 +130,9 @@ tryMerge, ) import Grisette.Internal.Core.Data.Symbol (Identifier) -import Grisette.Internal.Core.Data.Union (Union (UnionIf, UnionSingle)) +import Grisette.Internal.Core.Data.UnionBase + ( UnionBase (UnionIf, UnionSingle), + ) import Grisette.Internal.SymPrim.BV (IntN, WordN) import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) import Grisette.Internal.SymPrim.GeneralFun (type (-->)) @@ -243,13 +249,13 @@ runFreshTFromIndex instance - (UnionMergeable1 m, Mergeable a) => + (SymBranching m, Mergeable a) => SimpleMergeable (FreshT m a) where mrgIte = mrgIf instance - (UnionMergeable1 m) => + (SymBranching m) => SimpleMergeable1 (FreshT m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) @@ -260,8 +266,8 @@ tryMergeWithStrategy (liftRootStrategy2 s rootStrategy) $ f ident index instance - (UnionMergeable1 m) => - UnionMergeable1 (FreshT m) + (SymBranching m) => + SymBranching (FreshT m) where mrgIfWithStrategy s cond (FreshT t) (FreshT f) = FreshT $ \ident index -> @@ -279,6 +285,8 @@ runFreshT :: (Monad m) => FreshT m a -> Identifier -> m a runFreshT m ident = fst <$> runFreshTFromIndex m ident (FreshIndex 0) +-- | Run the symbolic generation with the given identifier and 0 as the initial +-- index, and try to merge the result. mrgRunFreshT :: (Monad m, TryMerge m, Mergeable a) => FreshT m a -> @@ -414,51 +422,51 @@ -- The following example generates a symbolic boolean. No specification is -- needed. -- - -- >>> runFresh (fresh ()) "a" :: UnionM SymBool + -- >>> runFresh (fresh ()) "a" :: Union SymBool -- {a@0} -- -- The following example generates booleans, which cannot be merged into a -- single value with type 'Bool'. No specification is needed. -- - -- >>> runFresh (fresh ()) "a" :: UnionM Bool + -- >>> runFresh (fresh ()) "a" :: Union Bool -- {If a@0 False True} -- -- The following example generates @Maybe Bool@s. -- There are more than one symbolic constants introduced, and their uniqueness -- is ensured. No specification is needed. -- - -- >>> runFresh (fresh ()) "a" :: UnionM (Maybe Bool) + -- >>> runFresh (fresh ()) "a" :: Union (Maybe Bool) -- {If a@0 Nothing (If a@1 (Just False) (Just True))} -- -- The following example generates lists of symbolic booleans with length 1 to 2. -- - -- >>> runFresh (fresh (ListSpec 1 2 ())) "a" :: UnionM [SymBool] + -- >>> runFresh (fresh (ListSpec 1 2 ())) "a" :: Union [SymBool] -- {If a@2 [a@1] [a@0,a@1]} -- -- When multiple symbolic values are generated, there will not be any -- identifier collision -- - -- >>> runFresh (do; a <- fresh (); b <- fresh (); return (a, b)) "a" :: (UnionM SymBool, UnionM SymBool) + -- >>> runFresh (do; a <- fresh (); b <- fresh (); return (a, b)) "a" :: (Union SymBool, Union SymBool) -- ({a@0},{a@1}) fresh :: (MonadFresh m) => spec -> - m (UnionM a) + m (Union a) default fresh :: (GenSymSimple spec a) => ( MonadFresh m ) => spec -> - m (UnionM a) + m (Union a) fresh spec = mrgSingle <$> simpleFresh spec -- | Generate a symbolic variable wrapped in a Union without the monadic context. -- A globally unique identifier should be supplied to ensure the uniqueness of -- symbolic constants in the generated symbolic values. -- --- >>> genSym (ListSpec 1 2 ()) "a" :: UnionM [SymBool] +-- >>> genSym (ListSpec 1 2 ()) "a" :: Union [SymBool] -- {If a@2 [a@1] [a@0,a@1]} -genSym :: (GenSym spec a) => spec -> Identifier -> UnionM a +genSym :: (GenSym spec a) => spec -> Identifier -> Union a genSym = runFresh . fresh -- | Class of types in which symbolic values can be generated with respect to some specification. @@ -499,7 +507,7 @@ freshNoSpec :: ( MonadFresh m ) => - m (UnionM (a c)) + m (Union (a c)) instance GenSymNoSpec U1 where freshNoSpec = return $ mrgSingle U1 @@ -522,11 +530,11 @@ forall m c. ( MonadFresh m ) => - m (UnionM ((a :+: b) c)) + m (Union ((a :+: b) c)) freshNoSpec = do cond :: bool <- simpleFresh () - l :: UnionM (a c) <- freshNoSpec - r :: UnionM (b c) <- freshNoSpec + l :: Union (a c) <- freshNoSpec + r :: Union (b c) <- freshNoSpec return $ mrgIf cond (fmap L1 l) (fmap R1 r) instance @@ -537,10 +545,10 @@ forall m c. ( MonadFresh m ) => - m (UnionM ((a :*: b) c)) + m (Union ((a :*: b) c)) freshNoSpec = do - l :: UnionM (a c) <- freshNoSpec - r :: UnionM (b c) <- freshNoSpec + l :: Union (a c) <- freshNoSpec + r :: Union (b c) <- freshNoSpec return $ do l1 <- l r1 <- r @@ -562,7 +570,7 @@ MonadFresh m ) => () -> - m (UnionM a) + m (Union a) derivedNoSpecFresh _ = tryMerge . fmap to <$> freshNoSpec class GenSymSimpleNoSpec a where @@ -591,7 +599,7 @@ -- your own types. -- -- This 'simpleFresh' implementation is for the types that does not need any specification. --- It will generate product types by generating each fields with '()' as specification. +-- It will generate product types by generating each fields with @()@ as specification. -- It will not work on sum types. -- -- __Note:__ __Never__ use on recursive types. @@ -667,7 +675,7 @@ -- The result will be wrapped in a union-like monad, and also a monad -- maintaining the 'MonadFresh' context. -- --- >>> runFresh (chooseFresh [1,2,3]) "a" :: UnionM Integer +-- >>> runFresh (chooseFresh [1,2,3]) "a" :: Union Integer -- {If a@0 1 (If a@1 2 3)} chooseFresh :: forall a m. @@ -675,7 +683,7 @@ MonadFresh m ) => [a] -> - m (UnionM a) + m (Union a) chooseFresh [x] = return $ mrgSingle x chooseFresh (r : rs) = do b <- simpleFresh () @@ -692,7 +700,7 @@ ) => [a] -> Identifier -> - UnionM a + Union a choose = runFresh . chooseFresh -- | Symbolically chooses one of the provided values. @@ -739,17 +747,17 @@ -- The result will be wrapped in a union-like monad, and also a monad -- maintaining the 'Fresh' context. -- --- >>> let a = runFresh (chooseFresh [1, 2]) "a" :: UnionM Integer --- >>> let b = runFresh (chooseFresh [2, 3]) "b" :: UnionM Integer --- >>> runFresh (chooseUnionFresh [a, b]) "c" :: UnionM Integer +-- >>> let a = runFresh (chooseFresh [1, 2]) "a" :: Union Integer +-- >>> let b = runFresh (chooseFresh [2, 3]) "b" :: Union Integer +-- >>> runFresh (chooseUnionFresh [a, b]) "c" :: Union Integer -- {If (&& c@0 a@0) 1 (If (|| c@0 b@0) 2 3)} chooseUnionFresh :: forall a m. ( Mergeable a, MonadFresh m ) => - [UnionM a] -> - m (UnionM a) + [Union a] -> + m (Union a) chooseUnionFresh [x] = return x chooseUnionFresh (r : rs) = do b <- simpleFresh () @@ -764,9 +772,9 @@ forall a. ( Mergeable a ) => - [UnionM a] -> + [Union a] -> Identifier -> - UnionM a + Union a chooseUnion = runFresh . chooseUnionFresh #define CONCRETE_GENSYM_SAME_SHAPE(type) \ @@ -841,7 +849,7 @@ -- | Specification for enum values with upper bound (exclusive). The result would chosen from [0 .. upperbound]. -- --- >>> runFresh (fresh (EnumGenUpperBound @Integer 4)) "c" :: UnionM Integer +-- >>> runFresh (fresh (EnumGenUpperBound @Integer 4)) "c" :: Union Integer -- {If c@0 0 (If c@1 1 (If c@2 2 3))} newtype EnumGenUpperBound a = EnumGenUpperBound a @@ -850,7 +858,7 @@ -- | Specification for numbers with lower bound (inclusive) and upper bound (exclusive) -- --- >>> runFresh (fresh (EnumGenBound @Integer 0 4)) "c" :: UnionM Integer +-- >>> runFresh (fresh (EnumGenBound @Integer 0 4)) "c" :: Union Integer -- {If c@0 0 (If c@1 1 (If c@2 2 3))} data EnumGenBound a = EnumGenBound a a @@ -893,8 +901,8 @@ GenSym (aspec, bspec) (Either a b) where fresh (aspec, bspec) = do - l :: UnionM a <- fresh aspec - r :: UnionM b <- fresh bspec + l :: Union a <- fresh aspec + r :: Union b <- fresh bspec chooseUnionFresh [Left <$> l, Right <$> r] -- Maybe @@ -920,7 +928,7 @@ where fresh aspec = do cond <- simpleFresh () - a :: UnionM a <- fresh aspec + a :: Union a <- fresh aspec return $ mrgIf cond (mrgSingle Nothing) (Just <$> a) -- List @@ -933,7 +941,7 @@ let xs = reverse $ scanr (:) [] l chooseUnionFresh $ tryMerge . sequence <$> xs where - gl :: (MonadFresh m) => Integer -> m [UnionM a] + gl :: (MonadFresh m) => Integer -> m [Union a] gl v1 | v1 <= 0 = return [] | otherwise = do @@ -943,10 +951,10 @@ -- | Specification for list generation. -- --- >>> runFresh (fresh (ListSpec 0 2 ())) "c" :: UnionM [SymBool] +-- >>> runFresh (fresh (ListSpec 0 2 ())) "c" :: Union [SymBool] -- {If c@2 [] (If c@3 [c@1] [c@0,c@1])} -- --- >>> runFresh (fresh (ListSpec 0 2 (SimpleListSpec 1 ()))) "c" :: UnionM [[SymBool]] +-- >>> runFresh (fresh (ListSpec 0 2 (SimpleListSpec 1 ()))) "c" :: Union [[SymBool]] -- {If c@2 [] (If c@3 [[c@1]] [[c@0],[c@1]])} data ListSpec spec = ListSpec { -- | The minimum length of the generated lists @@ -970,7 +978,7 @@ let xs = drop minLen $ reverse $ scanr (:) [] l chooseUnionFresh $ tryMerge . sequence <$> xs where - gl :: (MonadFresh m) => Int -> m [UnionM a] + gl :: (MonadFresh m) => Int -> m [Union a] gl currLen | currLen <= 0 = return [] | otherwise = do @@ -983,7 +991,7 @@ GenSym [a] [a] where fresh l = do - r :: [UnionM a] <- traverse fresh l + r :: [Union a] <- traverse fresh l return $ tryMerge $ sequence r instance @@ -1014,7 +1022,7 @@ else do tryMerge . sequence <$> gl len where - gl :: (MonadFresh m) => Int -> m [UnionM a] + gl :: (MonadFresh m) => Int -> m [Union a] gl currLen | currLen <= 0 = return [] | otherwise = do @@ -1725,18 +1733,18 @@ FreshIndex index <- nextFreshIndex return $ isym ident index -instance (GenSym spec a, Mergeable a) => GenSym spec (UnionM a) +instance (GenSym spec a, Mergeable a) => GenSym spec (Union a) -instance (GenSym spec a) => GenSymSimple spec (UnionM a) where +instance (GenSym spec a) => GenSymSimple spec (Union a) where simpleFresh spec = do res <- fresh spec if not (isMerged res) then error "Not merged" else return res instance (GenSym a a, Mergeable a) => - GenSym (UnionM a) a + GenSym (Union a) a where - fresh spec = go (underlyingUnion $ tryMerge spec) + fresh spec = go (unionBase $ tryMerge spec) where go (UnionSingle x) = fresh x go (UnionIf _ _ _ t f) = mrgIf <$> simpleFresh () <*> go t <*> go f diff --git a/src/Grisette/Internal/Core/Data/Class/IEEEFP.hs b/src/Grisette/Internal/Core/Data/Class/IEEEFP.hs --- a/src/Grisette/Internal/Core/Data/Class/IEEEFP.hs +++ b/src/Grisette/Internal/Core/Data/Class/IEEEFP.hs @@ -1,9 +1,17 @@ {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Grisette.Internal.Core.Data.Class.IEEEFP +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Internal.Core.Data.Class.IEEEFP ( fpIsNaN, fpIsPositiveZero, @@ -19,6 +27,7 @@ fpIsPoint, SymIEEEFPTraits (..), IEEEConstants (..), + IEEEFPRoundingMode (..), IEEEFPOp (..), IEEEFPRoundingOp (..), ) @@ -26,7 +35,7 @@ import Data.SBV (infinity, nan) import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Internal.SymPrim.FP (FP (FP), ValidFP) +import Grisette.Internal.SymPrim.FP (FP (FP), FPRoundingMode (RNA, RNE, RTN, RTP, RTZ), ValidFP) import Grisette.Internal.SymPrim.Prim.Internal.Instances.PEvalFP ( pevalFPBinaryTerm, pevalFPFMATerm, @@ -286,6 +295,7 @@ fpPositiveZero = con fpPositiveZero {-# INLINE fpPositiveZero #-} +-- | Operations on IEEE floating-point numbers, without rounding mode. class IEEEFPOp a where symFpAbs :: a -> a symFpNeg :: a -> a @@ -305,7 +315,49 @@ symFpMax (SymFP l) (SymFP r) = SymFP $ pevalFPBinaryTerm FPMax l r {-# INLINE symFpMax #-} -class IEEEFPRoundingOp a mode where +-- | Rounding modes for floating-point operations. +class IEEEFPRoundingMode mode where + -- | Round to nearest, ties to even. + rne :: mode + + -- | Round to nearest, ties to away from zero. + rna :: mode + + -- | Round towards positive infinity. + rtp :: mode + + -- | Round towards negative infinity. + rtn :: mode + + -- | Round towards zero. + rtz :: mode + +instance IEEEFPRoundingMode FPRoundingMode where + rne = RNE + {-# INLINE rne #-} + rna = RNA + {-# INLINE rna #-} + rtp = RTP + {-# INLINE rtp #-} + rtn = RTN + {-# INLINE rtn #-} + rtz = RTZ + {-# INLINE rtz #-} + +instance IEEEFPRoundingMode SymFPRoundingMode where + rne = con RNE + {-# INLINE rne #-} + rna = con RNA + {-# INLINE rna #-} + rtp = con RTP + {-# INLINE rtp #-} + rtn = con RTN + {-# INLINE rtn #-} + rtz = con RTZ + {-# INLINE rtz #-} + +-- | Operations on IEEE floating-point numbers, with rounding mode. +class (IEEEFPRoundingMode mode) => IEEEFPRoundingOp a mode | a -> mode where symFpAdd :: mode -> a -> a -> a symFpSub :: mode -> a -> a -> a symFpMul :: mode -> a -> a -> a diff --git a/src/Grisette/Internal/Core/Data/Class/ITEOp.hs b/src/Grisette/Internal/Core/Data/Class/ITEOp.hs --- a/src/Grisette/Internal/Core/Data/Class/ITEOp.hs +++ b/src/Grisette/Internal/Core/Data/Class/ITEOp.hs @@ -48,7 +48,8 @@ -- >>> :set -XFlexibleInstances -- >>> :set -XFunctionalDependencies --- | ITE operator for solvable (see "Grisette.Core#solvable")s, including symbolic boolean, integer, etc. +-- | ITE operator for solvable (see "Grisette.Core#g:solvable")s, including +-- symbolic boolean, integer, etc. -- -- >>> let a = "a" :: SymBool -- >>> let b = "b" :: SymBool @@ -56,6 +57,7 @@ -- >>> symIte a b c -- (ite a b c) class ITEOp v where + -- | Symbolic if-then-else. symIte :: SymBool -> v -> v -> v -- ITEOp instances diff --git a/src/Grisette/Internal/Core/Data/Class/LogicalOp.hs b/src/Grisette/Internal/Core/Data/Class/LogicalOp.hs --- a/src/Grisette/Internal/Core/Data/Class/LogicalOp.hs +++ b/src/Grisette/Internal/Core/Data/Class/LogicalOp.hs @@ -1,8 +1,17 @@ +-- | +-- Module : Grisette.Internal.Core.Data.Class.LogicalOp +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Internal.Core.Data.Class.LogicalOp ( LogicalOp (..), ) where +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) import Grisette.Internal.SymPrim.Prim.Term ( pevalAndTerm, pevalImplyTerm, @@ -23,8 +32,8 @@ -- | Symbolic logical operators for symbolic booleans. -- --- >>> let t = con True :: SymBool --- >>> let f = con False :: SymBool +-- >>> let t = true :: SymBool +-- >>> let f = false :: SymBool -- >>> let a = "a" :: SymBool -- >>> let b = "b" :: SymBool -- >>> t .|| f @@ -60,6 +69,14 @@ -- >>> a `symXor` b -- (|| (&& (! a) b) (&& a (! b))) class LogicalOp b where + -- | Constant true + true :: b + true = symNot false + + -- | Constant false + false :: b + false = symNot true + -- | Symbolic disjunction (.||) :: b -> b -> b a .|| b = symNot $ symNot a .&& symNot b @@ -87,10 +104,12 @@ a `symImplies` b = symNot a .|| b {-# INLINE symImplies #-} - {-# MINIMAL (.||), symNot | (.&&), symNot #-} + {-# MINIMAL (true | false), ((.||), symNot | (.&&), symNot) #-} -- LogicalOp instances instance LogicalOp Bool where + true = True + false = False (.||) = (||) {-# INLINE (.||) #-} (.&&) = (&&) @@ -99,6 +118,8 @@ {-# INLINE symNot #-} instance LogicalOp SymBool where + true = con True + false = con False (SymBool l) .|| (SymBool r) = SymBool $ pevalOrTerm l r (SymBool l) .&& (SymBool r) = SymBool $ pevalAndTerm l r symNot (SymBool v) = SymBool $ pevalNotTerm v diff --git a/src/Grisette/Internal/Core/Data/Class/Mergeable.hs b/src/Grisette/Internal/Core/Data/Class/Mergeable.hs --- a/src/Grisette/Internal/Core/Data/Class/Mergeable.hs +++ b/src/Grisette/Internal/Core/Data/Class/Mergeable.hs @@ -4,1060 +4,1160 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Internal.Core.Data.Class.Mergeable --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.Data.Class.Mergeable - ( -- * Merging strategy - MergingStrategy (..), - - -- * Mergeable - Mergeable (..), - Mergeable1 (..), - rootStrategy1, - Mergeable2 (..), - rootStrategy2, - Mergeable3 (..), - rootStrategy3, - Mergeable' (..), - derivedRootStrategy, - - -- * Combinators for manually building merging strategies - wrapStrategy, - product2Strategy, - DynamicSortedIdx (..), - StrategyList (..), - buildStrategyList, - resolveStrategy, - resolveStrategy', - ) -where - -import Control.Exception - ( ArithException - ( Denormal, - DivideByZero, - LossOfPrecision, - Overflow, - RatioZeroDenominator, - Underflow - ), - ) -import Control.Monad.Cont (ContT (ContT)) -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.Identity - ( Identity (Identity, runIdentity), - IdentityT (IdentityT, runIdentityT), - ) -import qualified Control.Monad.RWS.Lazy as RWSLazy -import qualified Control.Monad.RWS.Strict as RWSStrict -import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) -import qualified Control.Monad.State.Lazy as StateLazy -import qualified Control.Monad.State.Strict as StateStrict -import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Classes - ( Eq1, - Ord1, - Show1, - compare1, - eq1, - showsPrec1, - ) -import Data.Functor.Sum (Sum (InL, InR)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Kind (Type) -import qualified Data.Monoid as Monoid -import qualified Data.Text as T -import Data.Typeable - ( Typeable, - eqT, - type (:~:) (Refl), - ) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (+), type (<=)) -import Generics.Deriving - ( Default (Default), - Default1 (Default1), - Generic (Rep, from, to), - Generic1 (Rep1, from1, to1), - K1 (K1, unK1), - M1 (M1, unM1), - Par1 (Par1, unPar1), - Rec1 (Rec1, unRec1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast)) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Internal.SymPrim.BV - ( BitwidthMismatch, - IntN, - WordN, - ) -import Grisette.Internal.SymPrim.FP - ( FP, - FPRoundingMode, - ValidFP, - withValidFPProofs, - ) -import Grisette.Internal.SymPrim.GeneralFun (type (-->)) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep, - SupportedPrim, - ) -import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) -import Unsafe.Coerce (unsafeCoerce) - --- | Helper type for combining arbitrary number of indices into one. --- Useful when trying to write efficient merge strategy for lists/vectors. -data DynamicSortedIdx where - DynamicSortedIdx :: forall idx. (Show idx, Ord idx, Typeable idx) => idx -> DynamicSortedIdx - -instance Eq DynamicSortedIdx where - (DynamicSortedIdx (a :: a)) == (DynamicSortedIdx (b :: b)) = case eqT @a @b of - Just Refl -> a == b - _ -> False - {-# INLINE (==) #-} - -instance Ord DynamicSortedIdx where - compare (DynamicSortedIdx (a :: a)) (DynamicSortedIdx (b :: b)) = case eqT @a @b of - Just Refl -> compare a b - _ -> error "This Ord is incomplete" - {-# INLINE compare #-} - -instance Show DynamicSortedIdx where - show (DynamicSortedIdx a) = show a - --- | Resolves the indices and the terminal merge strategy for a value of some 'Mergeable' type. -resolveStrategy :: forall x. MergingStrategy x -> x -> ([DynamicSortedIdx], MergingStrategy x) -resolveStrategy s x = resolveStrategy' x s -{-# INLINE resolveStrategy #-} - --- | Resolves the indices and the terminal merge strategy for a value given a merge strategy for its type. -resolveStrategy' :: forall x. x -> MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) -resolveStrategy' x = go - where - go :: MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) - go (SortedStrategy idxFun subStrategy) = case go ss of - (idxs, r) -> (DynamicSortedIdx idx : idxs, r) - where - idx = idxFun x - ss = subStrategy idx - go s = ([], s) -{-# INLINE resolveStrategy' #-} - --- | Merging strategies. --- --- __You probably do not need to know the details of this type if you are only going__ --- __to use algebraic data types. You can get merging strategies for them with type__ --- __derivation.__ --- --- In Grisette, a merged union (if-then-else tree) follows the __/hierarchical/__ --- __/sorted representation invariant/__ with regards to some merging strategy. --- --- A merging strategy encodes how to merge a __/subset/__ of the values of a --- given type. We have three types of merging strategies: --- --- * Simple strategy --- * Sorted strategy --- * No strategy --- --- The 'SimpleStrategy' merges values with a simple merge function. --- For example, --- --- * the symbolic boolean values can be directly merged with 'symIte'. --- --- * the set @{1}@, which is a subset of the values of the type @Integer@, --- can be simply merged as the set contains only a single value. --- --- * all the 'Just' values of the type @Maybe SymBool@ can be simply merged --- by merging the wrapped symbolic boolean with 'symIte'. --- --- The 'SortedStrategy' merges values by first grouping the values with an --- indexing function, and the values with the same index will be organized as --- a sub-tree in the if-then-else structure of 'Grisette.Core.Data.UnionBase.UnionBase'. --- Each group (sub-tree) will be further merged with a sub-strategy for the --- index. --- The index type should be a totally ordered type (with the 'Ord' --- type class). Grisette will use the indexing function to partition the values --- into sub-trees, and organize them in a sorted way. The sub-trees will further --- be merged with the sub-strategies. For example, --- --- * all the integers can be merged with 'SortedStrategy' by indexing with --- the identity function and use the 'SimpleStrategy' shown before as the --- sub-strategies. --- --- * all the @Maybe SymBool@ values can be merged with 'SortedStrategy' by --- indexing with 'Data.Maybe.isJust', the 'Nothing' and 'Just' values can then --- then be merged with different simple strategies as sub-strategies. --- --- The 'NoStrategy' does not perform any merging. --- For example, we cannot merge values with function types that returns concrete --- lists. --- --- For ADTs, we can automatically derive the 'Mergeable' type class, which --- provides a merging strategy. --- --- If the derived version does not work for you, you should determine --- if your type can be directly merged with a merging function. If so, you can --- implement the merging strategy as a 'SimpleStrategy'. --- If the type cannot be directly merged with a merging function, but could be --- partitioned into subsets of values that can be simply merged with a function, --- you should implement the merging strategy as a 'SortedStrategy'. --- For easier building of the merging strategies, check out the combinators --- like `wrapStrategy`. --- --- For more details, please see the documents of the constructors, or refer to --- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf). -data MergingStrategy a where - -- | Simple mergeable strategy. - -- - -- For symbolic booleans, we can implement its merge strategy as follows: - -- - -- > SimpleStrategy symIte :: MergingStrategy SymBool - SimpleStrategy :: - -- | Merge function. - (SymBool -> a -> a -> a) -> - MergingStrategy a - -- | Sorted mergeable strategy. - -- - -- For Integers, we can implement its merge strategy as follows: - -- - -- > SortedStrategy id (\_ -> SimpleStrategy $ \_ t _ -> t) - -- - -- For @Maybe SymBool@, we can implement its merge strategy as follows: - -- - -- > SortedStrategy - -- > (\case; Nothing -> False; Just _ -> True) - -- > (\idx -> - -- > if idx - -- > then SimpleStrategy $ \_ t _ -> t - -- > else SimpleStrategy $ \cond (Just l) (Just r) -> Just $ symIte cond l r) - SortedStrategy :: - (Ord idx, Typeable idx, Show idx) => - -- | Indexing function - (a -> idx) -> - -- | Sub-strategy function - (idx -> MergingStrategy a) -> - MergingStrategy a - -- | For preventing the merging intentionally. This could be - -- useful for keeping some value concrete and may help generate more efficient - -- formulas. - -- - -- See [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf) for - -- details. - NoStrategy :: MergingStrategy a - --- | Useful utility function for building merge strategies manually. --- --- For example, to build the merge strategy for the just branch of @Maybe a@, --- one could write --- --- > wrapStrategy Just fromMaybe rootStrategy :: MergingStrategy (Maybe a) -wrapStrategy :: - -- | The merge strategy to be wrapped - MergingStrategy a -> - -- | The wrap function - (a -> b) -> - -- | The unwrap function, which does not have to be defined for every value - (b -> a) -> - MergingStrategy b -wrapStrategy (SimpleStrategy m) wrap unwrap = - SimpleStrategy - ( \cond ifTrue ifFalse -> - wrap $ m cond (unwrap ifTrue) (unwrap ifFalse) - ) -wrapStrategy (SortedStrategy idxFun substrategy) wrap unwrap = - SortedStrategy - (idxFun . unwrap) - (\idx -> wrapStrategy (substrategy idx) wrap unwrap) -wrapStrategy NoStrategy _ _ = NoStrategy -{-# INLINE wrapStrategy #-} - --- | Each type is associated with a root merge strategy given by 'rootStrategy'. --- The root merge strategy should be able to merge every value of the type. --- Grisette will use the root merge strategy to merge the values of the type in --- a union. --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving Mergeable via (Default X) -class Mergeable a where - -- | The root merging strategy for the type. - rootStrategy :: MergingStrategy a - --- | Lifting of the 'Mergeable' class to unary type constructors. -class Mergeable1 (u :: Type -> Type) where - -- | Lift merge strategy through the type constructor. - liftRootStrategy :: MergingStrategy a -> MergingStrategy (u a) - --- | Lift the root merge strategy through the unary type constructor. -rootStrategy1 :: (Mergeable a, Mergeable1 u) => MergingStrategy (u a) -rootStrategy1 = liftRootStrategy rootStrategy -{-# INLINE rootStrategy1 #-} - --- | Lifting of the 'Mergeable' class to binary type constructors. -class Mergeable2 (u :: Type -> Type -> Type) where - -- | Lift merge strategy through the type constructor. - liftRootStrategy2 :: MergingStrategy a -> MergingStrategy b -> MergingStrategy (u a b) - --- | Lift the root merge strategy through the binary type constructor. -rootStrategy2 :: (Mergeable a, Mergeable b, Mergeable2 u) => MergingStrategy (u a b) -rootStrategy2 = liftRootStrategy2 rootStrategy rootStrategy -{-# INLINE rootStrategy2 #-} - --- | Lifting of the 'Mergeable' class to ternary type constructors. -class Mergeable3 (u :: Type -> Type -> Type -> Type) where - -- | Lift merge strategy through the type constructor. - liftRootStrategy3 :: MergingStrategy a -> MergingStrategy b -> MergingStrategy c -> MergingStrategy (u a b c) - --- | Lift the root merge strategy through the binary type constructor. -rootStrategy3 :: (Mergeable a, Mergeable b, Mergeable c, Mergeable3 u) => MergingStrategy (u a b c) -rootStrategy3 = liftRootStrategy3 rootStrategy rootStrategy rootStrategy -{-# INLINE rootStrategy3 #-} - --- | Useful utility function for building merge strategies for product types --- manually. --- --- For example, to build the merge strategy for the following product type, --- one could write --- --- > data X = X { x1 :: Int, x2 :: Bool } --- > product2Strategy X (\(X a b) -> (a, b)) rootStrategy rootStrategy --- > :: MergingStrategy X -product2Strategy :: - -- | The wrap function - (a -> b -> r) -> - -- | The unwrap function, which does not have to be defined for every value - (r -> (a, b)) -> - -- | The first merge strategy to be wrapped - MergingStrategy a -> - -- | The second merge strategy to be wrapped - MergingStrategy b -> - MergingStrategy r -product2Strategy wrap unwrap strategy1 strategy2 = - case (strategy1, strategy2) of - (NoStrategy, _) -> NoStrategy - (_, NoStrategy) -> NoStrategy - (SimpleStrategy m1, SimpleStrategy m2) -> - SimpleStrategy $ \cond t f -> case (unwrap t, unwrap f) of - ((hdt, tlt), (hdf, tlf)) -> - wrap (m1 cond hdt hdf) (m2 cond tlt tlf) - (s1@(SimpleStrategy _), SortedStrategy idxf subf) -> - SortedStrategy (idxf . snd . unwrap) (product2Strategy wrap unwrap s1 . subf) - (SortedStrategy idxf subf, s2) -> - SortedStrategy (idxf . fst . unwrap) (\idx -> product2Strategy wrap unwrap (subf idx) s2) -{-# INLINE product2Strategy #-} - -instance (Mergeable' a, Mergeable' b) => Mergeable' (a :*: b) where - rootStrategy' = product2Strategy (:*:) (\(a :*: b) -> (a, b)) rootStrategy' rootStrategy' - {-# INLINE rootStrategy' #-} - --- instances - -#define CONCRETE_ORD_MERGEABLE(type) \ -instance Mergeable type where \ - rootStrategy = \ - let sub = SimpleStrategy $ \_ t _ -> t \ - in SortedStrategy id $ const sub - -#define CONCRETE_ORD_MERGEABLE_BV(type) \ -instance (KnownNat n, 1 <= n) => Mergeable (type n) where \ - rootStrategy = \ - let sub = SimpleStrategy $ \_ t _ -> t \ - in SortedStrategy id $ const sub - -#if 1 -CONCRETE_ORD_MERGEABLE(Bool) -CONCRETE_ORD_MERGEABLE(Integer) -CONCRETE_ORD_MERGEABLE(Char) -CONCRETE_ORD_MERGEABLE(Int) -CONCRETE_ORD_MERGEABLE(Int8) -CONCRETE_ORD_MERGEABLE(Int16) -CONCRETE_ORD_MERGEABLE(Int32) -CONCRETE_ORD_MERGEABLE(Int64) -CONCRETE_ORD_MERGEABLE(Word) -CONCRETE_ORD_MERGEABLE(Word8) -CONCRETE_ORD_MERGEABLE(Word16) -CONCRETE_ORD_MERGEABLE(Word32) -CONCRETE_ORD_MERGEABLE(Word64) -CONCRETE_ORD_MERGEABLE(Float) -CONCRETE_ORD_MERGEABLE(Double) -CONCRETE_ORD_MERGEABLE(B.ByteString) -CONCRETE_ORD_MERGEABLE(T.Text) -CONCRETE_ORD_MERGEABLE(FPRoundingMode) -CONCRETE_ORD_MERGEABLE_BV(WordN) -CONCRETE_ORD_MERGEABLE_BV(IntN) -#endif - -instance (ValidFP eb sb) => Mergeable (FP eb sb) where - rootStrategy = - let sub = SimpleStrategy $ \_ t _ -> t - in withValidFPProofs @eb @sb - $ SortedStrategy - (\fp -> (bitCast fp :: WordN (eb + sb))) - $ const sub - --- () -deriving via (Default ()) instance Mergeable () - --- Either -deriving via (Default (Either e a)) instance (Mergeable e, Mergeable a) => Mergeable (Either e a) - -deriving via (Default1 (Either e)) instance (Mergeable e) => Mergeable1 (Either e) - -instance Mergeable2 Either where - liftRootStrategy2 m1 m2 = - SortedStrategy - ( \case - Left _ -> False - Right _ -> True - ) - ( \case - False -> wrapStrategy m1 Left (\case (Left v) -> v; _ -> undefined) - True -> wrapStrategy m2 Right (\case (Right v) -> v; _ -> undefined) - ) - {-# INLINE liftRootStrategy2 #-} - --- Maybe -deriving via (Default (Maybe a)) instance (Mergeable a) => Mergeable (Maybe a) - -deriving via (Default1 Maybe) instance Mergeable1 Maybe - --- | Helper type for building efficient merge strategy for list-like containers. -data StrategyList container where - StrategyList :: - forall a container. - container [DynamicSortedIdx] -> - container (MergingStrategy a) -> - StrategyList container - --- | Helper function for building efficient merge strategy for list-like containers. -buildStrategyList :: - forall a container. - (Functor container) => - MergingStrategy a -> - container a -> - StrategyList container -buildStrategyList s l = StrategyList idxs strategies - where - r = resolveStrategy s <$> l - idxs = fst <$> r - strategies = snd <$> r -{-# INLINE buildStrategyList #-} - -instance (Eq1 container) => Eq (StrategyList container) where - (StrategyList idxs1 _) == (StrategyList idxs2 _) = eq1 idxs1 idxs2 - {-# INLINE (==) #-} - -instance (Ord1 container) => Ord (StrategyList container) where - compare (StrategyList idxs1 _) (StrategyList idxs2 _) = compare1 idxs1 idxs2 - {-# INLINE compare #-} - -instance (Show1 container) => Show (StrategyList container) where - showsPrec i (StrategyList idxs1 _) = showsPrec1 i idxs1 - --- List -instance (Mergeable a) => Mergeable [a] where - rootStrategy = case rootStrategy :: MergingStrategy a of - SimpleStrategy m -> - SortedStrategy length $ \_ -> - SimpleStrategy $ \cond -> zipWith (m cond) - NoStrategy -> - SortedStrategy length $ const NoStrategy - _ -> SortedStrategy length $ \_ -> - SortedStrategy (buildStrategyList rootStrategy) $ \(StrategyList _ strategies) -> - let s :: [MergingStrategy a] = unsafeCoerce strategies - allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s - in if allSimple - then SimpleStrategy $ \cond l r -> - (\case (SimpleStrategy f, l1, r1) -> f cond l1 r1; _ -> error "impossible") <$> zip3 s l r - else NoStrategy - {-# INLINE rootStrategy #-} - -instance Mergeable1 [] where - liftRootStrategy (ms :: MergingStrategy a) = case ms of - SimpleStrategy m -> - SortedStrategy length $ \_ -> - SimpleStrategy $ \cond -> zipWith (m cond) - NoStrategy -> - SortedStrategy length $ const NoStrategy - _ -> SortedStrategy length $ \_ -> - SortedStrategy (buildStrategyList ms) $ \(StrategyList _ strategies) -> - let s :: [MergingStrategy a] = unsafeCoerce strategies - allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s - in if allSimple - then SimpleStrategy $ \cond l r -> - (\case (SimpleStrategy f, l1, r1) -> f cond l1 r1; _ -> error "impossible") <$> zip3 s l r - else NoStrategy - {-# INLINE liftRootStrategy #-} - --- (,) -deriving via (Default (a, b)) instance (Mergeable a, Mergeable b) => Mergeable (a, b) - -deriving via (Default1 ((,) a)) instance (Mergeable a) => Mergeable1 ((,) a) - -instance Mergeable2 (,) where - liftRootStrategy2 = product2Strategy (,) id - {-# INLINE liftRootStrategy2 #-} - --- (,,) -deriving via - (Default (a, b, c)) - instance - (Mergeable a, Mergeable b, Mergeable c) => Mergeable (a, b, c) - -deriving via - (Default1 ((,,) a b)) - instance - (Mergeable a, Mergeable b) => Mergeable1 ((,,) a b) - -instance (Mergeable a) => Mergeable2 ((,,) a) where - liftRootStrategy2 = liftRootStrategy3 rootStrategy - {-# INLINE liftRootStrategy2 #-} - -instance Mergeable3 (,,) where - liftRootStrategy3 m1 m2 m3 = - product2Strategy - (\a (b, c) -> (a, b, c)) - (\(a, b, c) -> (a, (b, c))) - m1 - (liftRootStrategy2 m2 m3) - {-# INLINE liftRootStrategy3 #-} - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => - Mergeable (a, b, c, d) - -deriving via - (Default1 ((,,,) a b c)) - instance - (Mergeable a, Mergeable b, Mergeable c) => - Mergeable1 ((,,,) a b c) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => - Mergeable (a, b, c, d, e) - -deriving via - (Default1 ((,,,,) a b c d)) - instance - (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => - Mergeable1 ((,,,,) a b c d) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f - ) => - Mergeable (a, b, c, d, e, f) - -deriving via - (Default1 ((,,,,,) a b c d e)) - instance - (Mergeable a, Mergeable b, Mergeable c, Mergeable d, Mergeable e) => - Mergeable1 ((,,,,,) a b c d e) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f, - Mergeable g - ) => - Mergeable (a, b, c, d, e, f, g) - -deriving via - (Default1 ((,,,,,,) a b c d e f)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f - ) => - Mergeable1 ((,,,,,,) a b c d e f) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f, - Mergeable g, - Mergeable h - ) => - Mergeable (a, b, c, d, e, f, g, h) - -deriving via - (Default1 ((,,,,,,,) a b c d e f g)) - instance - ( Mergeable a, - Mergeable b, - Mergeable c, - Mergeable d, - Mergeable e, - Mergeable f, - Mergeable g - ) => - Mergeable1 ((,,,,,,,) a b c d e f g) - --- function -instance (Mergeable b) => Mergeable (a -> b) where - rootStrategy = case rootStrategy @b of - SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) - _ -> NoStrategy - {-# INLINE rootStrategy #-} - -instance Mergeable1 ((->) a) where - liftRootStrategy ms = case ms of - SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) - _ -> NoStrategy - {-# INLINE liftRootStrategy #-} - --- MaybeT -instance (Mergeable1 m, Mergeable a) => Mergeable (MaybeT m a) where - rootStrategy = wrapStrategy rootStrategy1 MaybeT runMaybeT - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m) => Mergeable1 (MaybeT m) where - liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) MaybeT runMaybeT - {-# INLINE liftRootStrategy #-} - --- ExceptT -instance - (Mergeable1 m, Mergeable e, Mergeable a) => - Mergeable (ExceptT e m a) - where - rootStrategy = wrapStrategy rootStrategy1 ExceptT runExceptT - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m, Mergeable e) => Mergeable1 (ExceptT e m) where - liftRootStrategy m = wrapStrategy (liftRootStrategy (liftRootStrategy m)) ExceptT runExceptT - {-# INLINE liftRootStrategy #-} - --- state -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (StateLazy.StateT s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) StateLazy.StateT StateLazy.runStateT - {-# INLINE rootStrategy #-} - -instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateLazy.StateT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) - StateLazy.StateT - StateLazy.runStateT - {-# INLINE liftRootStrategy #-} - -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (StateStrict.StateT s m a) - where - rootStrategy = - wrapStrategy (liftRootStrategy rootStrategy1) StateStrict.StateT StateStrict.runStateT - {-# INLINE rootStrategy #-} - -instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateStrict.StateT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) - StateStrict.StateT - StateStrict.runStateT - {-# INLINE liftRootStrategy #-} - --- writer -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (WriterLazy.WriterT s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) WriterLazy.WriterT WriterLazy.runWriterT - {-# INLINE rootStrategy #-} - -instance (Mergeable s, Mergeable1 m) => Mergeable1 (WriterLazy.WriterT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy2 m rootStrategy)) - WriterLazy.WriterT - WriterLazy.runWriterT - {-# INLINE liftRootStrategy #-} - -instance - (Mergeable s, Mergeable a, Mergeable1 m) => - Mergeable (WriterStrict.WriterT s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) WriterStrict.WriterT WriterStrict.runWriterT - {-# INLINE rootStrategy #-} - -instance (Mergeable s, Mergeable1 m) => Mergeable1 (WriterStrict.WriterT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy2 m rootStrategy)) - WriterStrict.WriterT - WriterStrict.runWriterT - {-# INLINE liftRootStrategy #-} - --- reader -instance - (Mergeable a, Mergeable1 m) => - Mergeable (ReaderT s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy rootStrategy1) ReaderT runReaderT - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m) => Mergeable1 (ReaderT s m) where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy m)) - ReaderT - runReaderT - {-# INLINE liftRootStrategy #-} - --- Sum -instance - (Mergeable1 l, Mergeable1 r, Mergeable x) => - Mergeable (Sum l r x) - where - rootStrategy = - SortedStrategy - ( \case - InL _ -> False - InR _ -> True - ) - ( \case - False -> wrapStrategy rootStrategy1 InL (\case (InL v) -> v; _ -> error "impossible") - True -> wrapStrategy rootStrategy1 InR (\case (InR v) -> v; _ -> error "impossible") - ) - {-# INLINE rootStrategy #-} - -instance (Mergeable1 l, Mergeable1 r) => Mergeable1 (Sum l r) where - liftRootStrategy m = - SortedStrategy - ( \case - InL _ -> False - InR _ -> True - ) - ( \case - False -> wrapStrategy (liftRootStrategy m) InL (\case (InL v) -> v; _ -> error "impossible") - True -> wrapStrategy (liftRootStrategy m) InR (\case (InR v) -> v; _ -> error "impossible") - ) - {-# INLINE liftRootStrategy #-} - --- Ordering -deriving via - (Default Ordering) - instance - Mergeable Ordering - --- Generic -deriving via - (Default (U1 x)) - instance - Mergeable (U1 x) - -deriving via - (Default (V1 x)) - instance - Mergeable (V1 x) - -deriving via - (Default (K1 i c x)) - instance - (Mergeable c) => Mergeable (K1 i c x) - -deriving via - (Default (M1 i c a x)) - instance - (Mergeable (a x)) => Mergeable (M1 i c a x) - -deriving via - (Default ((a :+: b) x)) - instance - (Mergeable (a x), Mergeable (b x)) => Mergeable ((a :+: b) x) - -deriving via - (Default ((a :*: b) x)) - instance - (Mergeable (a x), Mergeable (b x)) => Mergeable ((a :*: b) x) - --- Identity -instance (Mergeable a) => Mergeable (Identity a) where - rootStrategy = wrapStrategy rootStrategy Identity runIdentity - {-# INLINE rootStrategy #-} - -instance Mergeable1 Identity where - liftRootStrategy m = wrapStrategy m Identity runIdentity - {-# INLINE liftRootStrategy #-} - --- IdentityT -instance (Mergeable1 m, Mergeable a) => Mergeable (IdentityT m a) where - rootStrategy = wrapStrategy rootStrategy1 IdentityT runIdentityT - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m) => Mergeable1 (IdentityT m) where - liftRootStrategy m = wrapStrategy (liftRootStrategy m) IdentityT runIdentityT - {-# INLINE liftRootStrategy #-} - --- ContT -instance (Mergeable1 m, Mergeable r) => Mergeable (ContT r m a) where - rootStrategy = - wrapStrategy - (liftRootStrategy rootStrategy1) - ContT - (\(ContT v) -> v) - {-# INLINE rootStrategy #-} - -instance (Mergeable1 m, Mergeable r) => Mergeable1 (ContT r m) where - liftRootStrategy _ = - wrapStrategy - (liftRootStrategy rootStrategy1) - ContT - (\(ContT v) -> v) - {-# INLINE liftRootStrategy #-} - --- RWS -instance - (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => - Mergeable (RWSLazy.RWST r w s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) RWSLazy.RWST (\(RWSLazy.RWST m) -> m) - {-# INLINE rootStrategy #-} - -instance - (Mergeable s, Mergeable w, Mergeable1 m) => - Mergeable1 (RWSLazy.RWST r w s m) - where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy3 m rootStrategy rootStrategy)))) - RWSLazy.RWST - (\(RWSLazy.RWST rws) -> rws) - {-# INLINE liftRootStrategy #-} - -instance - (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => - Mergeable (RWSStrict.RWST r w s m a) - where - rootStrategy = wrapStrategy (liftRootStrategy (liftRootStrategy rootStrategy1)) RWSStrict.RWST (\(RWSStrict.RWST m) -> m) - {-# INLINE rootStrategy #-} - -instance - (Mergeable s, Mergeable w, Mergeable1 m) => - Mergeable1 (RWSStrict.RWST r w s m) - where - liftRootStrategy m = - wrapStrategy - (liftRootStrategy (liftRootStrategy (liftRootStrategy (liftRootStrategy3 m rootStrategy rootStrategy)))) - RWSStrict.RWST - (\(RWSStrict.RWST rws) -> rws) - {-# INLINE liftRootStrategy #-} - --- Data.Monoid module -deriving via - (Default (Monoid.Sum a)) - instance - (Mergeable a) => Mergeable (Monoid.Sum a) - -deriving via (Default1 Monoid.Sum) instance Mergeable1 Monoid.Sum - -#define MERGEABLE_SIMPLE(symtype) \ -instance Mergeable symtype where \ - rootStrategy = SimpleStrategy symIte - -#define MERGEABLE_BV(symtype) \ -instance (KnownNat n, 1 <= n) => Mergeable (symtype n) where \ - rootStrategy = SimpleStrategy symIte - -#define MERGEABLE_FUN(cop, op) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - Mergeable (op sa sb) where \ - rootStrategy = SimpleStrategy symIte - -#if 1 -MERGEABLE_SIMPLE(SymBool) -MERGEABLE_SIMPLE(SymInteger) -MERGEABLE_SIMPLE(SymFPRoundingMode) -MERGEABLE_BV(SymIntN) -MERGEABLE_BV(SymWordN) -MERGEABLE_FUN((=->), (=~>)) -MERGEABLE_FUN((-->), (-~>)) -#endif - -instance (ValidFP eb sb) => Mergeable (SymFP eb sb) where - rootStrategy = SimpleStrategy symIte - --- Exceptions -instance Mergeable ArithException where - rootStrategy = - SortedStrategy - ( \case - Overflow -> 0 :: Int - Underflow -> 1 :: Int - LossOfPrecision -> 2 :: Int - DivideByZero -> 3 :: Int - Denormal -> 4 :: Int - RatioZeroDenominator -> 5 :: Int - ) - (const $ SimpleStrategy $ \_ l _ -> l) - -deriving via (Default BitwidthMismatch) instance (Mergeable BitwidthMismatch) - -deriving via (Default AssertionError) instance Mergeable AssertionError - -deriving via (Default VerificationConditions) instance Mergeable VerificationConditions - -instance (Generic a, Mergeable' (Rep a)) => Mergeable (Default a) where - rootStrategy = unsafeCoerce (derivedRootStrategy :: MergingStrategy a) - {-# NOINLINE rootStrategy #-} - --- | Generic derivation for the 'Mergeable' class. --- --- Usually you can derive the merging strategy with the @DerivingVia@ and --- @DerivingStrategies@ extension. --- --- > data X = ... deriving (Generic) deriving Mergeable via (Default X) -derivedRootStrategy :: (Generic a, Mergeable' (Rep a)) => MergingStrategy a -derivedRootStrategy = wrapStrategy rootStrategy' to from -{-# INLINE derivedRootStrategy #-} - -instance (Generic1 u, Mergeable1' (Rep1 u)) => Mergeable1 (Default1 u) where - liftRootStrategy = unsafeCoerce (derivedLiftMergingStrategy :: MergingStrategy a -> MergingStrategy (u a)) - {-# NOINLINE liftRootStrategy #-} - -class Mergeable1' (u :: Type -> Type) where - liftRootStrategy' :: MergingStrategy a -> MergingStrategy (u a) - -instance Mergeable1' U1 where - liftRootStrategy' _ = SimpleStrategy (\_ t _ -> t) - {-# INLINE liftRootStrategy' #-} - -instance Mergeable1' V1 where - liftRootStrategy' _ = SimpleStrategy (\_ t _ -> t) - {-# INLINE liftRootStrategy' #-} - -instance Mergeable1' Par1 where - liftRootStrategy' m = wrapStrategy m Par1 unPar1 - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable1 f) => Mergeable1' (Rec1 f) where - liftRootStrategy' m = wrapStrategy (liftRootStrategy m) Rec1 unRec1 - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable c) => Mergeable1' (K1 i c) where - liftRootStrategy' _ = wrapStrategy rootStrategy K1 unK1 - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable1' a) => Mergeable1' (M1 i c a) where - liftRootStrategy' m = wrapStrategy (liftRootStrategy' m) M1 unM1 - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable1' a, Mergeable1' b) => Mergeable1' (a :+: b) where - liftRootStrategy' m = - SortedStrategy - ( \case - L1 _ -> False - R1 _ -> True - ) - ( \idx -> - if not idx - then wrapStrategy (liftRootStrategy' m) L1 (\case (L1 v) -> v; _ -> error "impossible") - else wrapStrategy (liftRootStrategy' m) R1 (\case (R1 v) -> v; _ -> error "impossible") - ) - {-# INLINE liftRootStrategy' #-} - -instance (Mergeable1' a, Mergeable1' b) => Mergeable1' (a :*: b) where - liftRootStrategy' m = product2Strategy (:*:) (\(a :*: b) -> (a, b)) (liftRootStrategy' m) (liftRootStrategy' m) - {-# INLINE liftRootStrategy' #-} - --- | Generic derivation for the 'Mergeable' class. -derivedLiftMergingStrategy :: (Generic1 u, Mergeable1' (Rep1 u)) => MergingStrategy a -> MergingStrategy (u a) -derivedLiftMergingStrategy m = wrapStrategy (liftRootStrategy' m) to1 from1 -{-# INLINE derivedLiftMergingStrategy #-} - --- | Auxiliary class for the generic derivation for the 'Mergeable' class. -class Mergeable' f where - rootStrategy' :: MergingStrategy (f a) - -instance Mergeable' U1 where - rootStrategy' = SimpleStrategy (\_ t _ -> t) - {-# INLINE rootStrategy' #-} - -instance Mergeable' V1 where - rootStrategy' = SimpleStrategy (\_ t _ -> t) - {-# INLINE rootStrategy' #-} - -instance (Mergeable c) => Mergeable' (K1 i c) where - rootStrategy' = wrapStrategy rootStrategy K1 unK1 - {-# INLINE rootStrategy' #-} - -instance (Mergeable' a) => Mergeable' (M1 i c a) where - rootStrategy' = wrapStrategy rootStrategy' M1 unM1 - {-# INLINE rootStrategy' #-} - -instance (Mergeable' a, Mergeable' b) => Mergeable' (a :+: b) where - rootStrategy' = - SortedStrategy - ( \case - L1 _ -> False - R1 _ -> True - ) - ( \idx -> - if not idx - then wrapStrategy rootStrategy' L1 (\case (L1 v) -> v; _ -> undefined) - else wrapStrategy rootStrategy' R1 (\case (R1 v) -> v; _ -> undefined) - ) - {-# INLINE rootStrategy' #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.Mergeable +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.Mergeable + ( -- * Merging strategy + MergingStrategy (..), + + -- * Mergeable + Mergeable (..), + Mergeable1 (..), + rootStrategy1, + Mergeable2 (..), + rootStrategy2, + Mergeable3 (..), + rootStrategy3, + + -- * Generic 'Mergeable' + MergeableArgs (..), + GMergeable (..), + genericRootStrategy, + genericLiftRootStrategy, + + -- * Combinators for manually building merging strategies + wrapStrategy, + product2Strategy, + DynamicSortedIdx (..), + StrategyList (..), + buildStrategyList, + resolveStrategy, + resolveStrategy', + ) +where + +import Control.Exception + ( ArithException + ( Denormal, + DivideByZero, + LossOfPrecision, + Overflow, + RatioZeroDenominator, + Underflow + ), + ) +import Control.Monad.Cont (ContT (ContT)) +import Control.Monad.Except (ExceptT (ExceptT), runExceptT) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT, runIdentityT), + ) +import qualified Control.Monad.RWS.Lazy as RWSLazy +import qualified Control.Monad.RWS.Strict as RWSStrict +import Control.Monad.Reader (ReaderT (ReaderT, runReaderT)) +import qualified Control.Monad.State.Lazy as StateLazy +import qualified Control.Monad.State.Strict as StateStrict +import Control.Monad.Trans.Maybe (MaybeT (MaybeT, runMaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Classes + ( Eq1, + Ord1, + Show1, + compare1, + eq1, + showsPrec1, + ) +import Data.Functor.Compose (Compose (Compose, getCompose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Monoid (Alt, Ap, Endo (Endo, appEndo)) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import qualified Data.Text as T +import Data.Typeable + ( Typeable, + eqT, + type (:~:) (Refl), + ) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (+), type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1, unK1), + M1 (M1, unM1), + Par1 (Par1, unPar1), + Rec1 (Rec1, unRec1), + U1, + V1, + (:.:) (Comp1, unComp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast)) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.SymPrim.BV + ( BitwidthMismatch, + IntN, + WordN, + ) +import Grisette.Internal.SymPrim.FP + ( FP, + FPRoundingMode, + ValidFP, + withValidFPProofs, + ) +import Grisette.Internal.SymPrim.GeneralFun (type (-->)) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Internal.SymPrim.SymFP (SymFP, SymFPRoundingMode) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) +import Unsafe.Coerce (unsafeCoerce) + +-- | Merging strategies. +-- +-- __You probably do not need to know the details of this type if you are only__ +-- __going to use algebraic data types. You can get merging strategies for__ +-- __them with type derivation.__ +-- +-- In Grisette, a merged union (if-then-else tree) follows the +-- __/hierarchical sorted representation invariant/__ with regards to some +-- merging strategy. +-- +-- A merging strategy encodes how to merge a __/subset/__ of the values of a +-- given type. We have three types of merging strategies: +-- +-- * Simple strategy +-- * Sorted strategy +-- * No strategy +-- +-- The 'SimpleStrategy' merges values with a simple merge function. +-- For example, +-- +-- * the symbolic boolean values can be directly merged with 'symIte'. +-- +-- * the set @{1}@, which is a subset of the values of the type @Integer@, +-- can be simply merged as the set contains only a single value. +-- +-- * all the 'Just' values of the type @Maybe SymBool@ can be simply merged +-- by merging the wrapped symbolic boolean with 'symIte'. +-- +-- The 'SortedStrategy' merges values by first grouping the values with an +-- indexing function, and the values with the same index will be organized as +-- a sub-tree in the if-then-else structure of +-- 'Grisette.Core.Data.UnionBase.UnionBase'. Each group (sub-tree) will be +-- further merged with a sub-strategy for the index. +-- The index type should be a totally ordered type (with the 'Ord' +-- type class). Grisette will use the indexing function to partition the values +-- into sub-trees, and organize them in a sorted way. The sub-trees will further +-- be merged with the sub-strategies. For example, +-- +-- * all the integers can be merged with 'SortedStrategy' by indexing with +-- the identity function and use the 'SimpleStrategy' shown before as the +-- sub-strategies. +-- +-- * all the @Maybe SymBool@ values can be merged with 'SortedStrategy' by +-- indexing with 'Data.Maybe.isJust', the 'Nothing' and 'Just' values can +-- then be merged with different simple strategies as sub-strategies. +-- +-- The 'NoStrategy' does not perform any merging. +-- For example, we cannot merge values with function types that returns concrete +-- lists. +-- +-- For ADTs, we can automatically derive the 'Mergeable' type class, which +-- provides a merging strategy. +-- +-- If the derived version does not work for you, you should determine +-- if your type can be directly merged with a merging function. If so, you can +-- implement the merging strategy as a 'SimpleStrategy'. +-- If the type cannot be directly merged with a merging function, but could be +-- partitioned into subsets of values that can be simply merged with a function, +-- you should implement the merging strategy as a 'SortedStrategy'. +-- For easier building of the merging strategies, check out the combinators +-- like `wrapStrategy`. +-- +-- For more details, please see the documents of the constructors, or refer to +-- [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf). +data MergingStrategy a where + -- | Simple mergeable strategy. + -- + -- For symbolic booleans, we can implement its merge strategy as follows: + -- + -- > SimpleStrategy symIte :: MergingStrategy SymBool + SimpleStrategy :: + -- | Merge function. + (SymBool -> a -> a -> a) -> + MergingStrategy a + -- | Sorted mergeable strategy. + -- + -- For Integers, we can implement its merge strategy as follows: + -- + -- > SortedStrategy id (\_ -> SimpleStrategy $ \_ t _ -> t) + -- + -- For @Maybe SymBool@, we can implement its merge strategy as follows: + -- + -- > SortedStrategy + -- > (\case; Nothing -> False; Just _ -> True) + -- > (\idx -> + -- > if idx + -- > then SimpleStrategy $ \_ t _ -> t + -- > else SimpleStrategy $ \cond (Just l) (Just r) -> Just $ symIte cond l r) + SortedStrategy :: + (Ord idx, Typeable idx, Show idx) => + -- | Indexing function + (a -> idx) -> + -- | Sub-strategy function + (idx -> MergingStrategy a) -> + MergingStrategy a + -- | For preventing the merging intentionally. This could be + -- useful for keeping some value concrete and may help generate more efficient + -- formulas. + -- + -- See [Grisette's paper](https://lsrcz.github.io/files/POPL23.pdf) for + -- details. + NoStrategy :: MergingStrategy a + +-- | Each type is associated with a root merge strategy given by 'rootStrategy'. +-- The root merge strategy should be able to merge every value of the type. +-- Grisette will use the root merge strategy to merge the values of the type in +-- a union. +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving Mergeable via (Default X) +class Mergeable a where + -- | The root merging strategy for the type. + rootStrategy :: MergingStrategy a + +-- | Lifting of the 'Mergeable' class to unary type constructors. +class + (forall a. (Mergeable a) => Mergeable (u a)) => + Mergeable1 (u :: Type -> Type) + where + -- | Lift merge strategy through the type constructor. + liftRootStrategy :: MergingStrategy a -> MergingStrategy (u a) + +-- | Lift the root merge strategy through the unary type constructor. +rootStrategy1 :: (Mergeable a, Mergeable1 u) => MergingStrategy (u a) +rootStrategy1 = liftRootStrategy rootStrategy +{-# INLINE rootStrategy1 #-} + +-- | Lifting of the 'Mergeable' class to binary type constructors. +class + (forall a. (Mergeable a) => Mergeable1 (u a)) => + Mergeable2 (u :: Type -> Type -> Type) + where + -- | Lift merge strategy through the type constructor. + liftRootStrategy2 :: + MergingStrategy a -> + MergingStrategy b -> + MergingStrategy (u a b) + +-- | Lift the root merge strategy through the binary type constructor. +rootStrategy2 :: + (Mergeable a, Mergeable b, Mergeable2 u) => + MergingStrategy (u a b) +rootStrategy2 = liftRootStrategy2 rootStrategy rootStrategy +{-# INLINE rootStrategy2 #-} + +-- | Lifting of the 'Mergeable' class to ternary type constructors. +class + (forall a. (Mergeable a) => Mergeable2 (u a)) => + Mergeable3 (u :: Type -> Type -> Type -> Type) + where + -- | Lift merge strategy through the type constructor. + liftRootStrategy3 :: + MergingStrategy a -> + MergingStrategy b -> + MergingStrategy c -> + MergingStrategy (u a b c) + +-- | Lift the root merge strategy through the binary type constructor. +rootStrategy3 :: + (Mergeable a, Mergeable b, Mergeable c, Mergeable3 u) => + MergingStrategy (u a b c) +rootStrategy3 = liftRootStrategy3 rootStrategy rootStrategy rootStrategy +{-# INLINE rootStrategy3 #-} + +-- | Useful utility function for building merge strategies manually. +-- +-- For example, to build the merge strategy for the just branch of @Maybe a@, +-- one could write +-- +-- > wrapStrategy Just fromMaybe rootStrategy :: MergingStrategy (Maybe a) +wrapStrategy :: + -- | The merge strategy to be wrapped + MergingStrategy a -> + -- | The wrap function + (a -> b) -> + -- | The unwrap function, which does not have to be defined for every value + (b -> a) -> + MergingStrategy b +wrapStrategy (SimpleStrategy m) wrap unwrap = + SimpleStrategy + ( \cond ifTrue ifFalse -> + wrap $ m cond (unwrap ifTrue) (unwrap ifFalse) + ) +wrapStrategy (SortedStrategy idxFun substrategy) wrap unwrap = + SortedStrategy + (idxFun . unwrap) + (\idx -> wrapStrategy (substrategy idx) wrap unwrap) +wrapStrategy NoStrategy _ _ = NoStrategy +{-# INLINE wrapStrategy #-} + +-- | Useful utility function for building merge strategies for product types +-- manually. +-- +-- For example, to build the merge strategy for the following product type, +-- one could write +-- +-- > data X = X { x1 :: Int, x2 :: Bool } +-- > product2Strategy X (\(X a b) -> (a, b)) rootStrategy rootStrategy +-- > :: MergingStrategy X +product2Strategy :: + -- | The wrap function + (a -> b -> r) -> + -- | The unwrap function, which does not have to be defined for every value + (r -> (a, b)) -> + -- | The first merge strategy to be wrapped + MergingStrategy a -> + -- | The second merge strategy to be wrapped + MergingStrategy b -> + MergingStrategy r +product2Strategy wrap unwrap strategy1 strategy2 = + case (strategy1, strategy2) of + (NoStrategy, _) -> NoStrategy + (_, NoStrategy) -> NoStrategy + (SimpleStrategy m1, SimpleStrategy m2) -> + SimpleStrategy $ \cond t f -> case (unwrap t, unwrap f) of + ((hdt, tlt), (hdf, tlf)) -> + wrap (m1 cond hdt hdf) (m2 cond tlt tlf) + (s1@(SimpleStrategy _), SortedStrategy idxf subf) -> + SortedStrategy + (idxf . snd . unwrap) + (product2Strategy wrap unwrap s1 . subf) + (SortedStrategy idxf subf, s2) -> + SortedStrategy + (idxf . fst . unwrap) + (\idx -> product2Strategy wrap unwrap (subf idx) s2) +{-# INLINE product2Strategy #-} + +-- Derivations + +-- | The arguments to the generic merging strategy function. +data family MergeableArgs arity a :: Type + +data instance MergeableArgs Arity0 _ = MergeableArgs0 + +newtype instance MergeableArgs Arity1 a = MergeableArgs1 (MergingStrategy a) + +-- | The class of types that can be generically merged. +class GMergeable arity f where + grootStrategy :: MergeableArgs arity a -> MergingStrategy (f a) + +instance GMergeable arity V1 where + grootStrategy _ = SimpleStrategy (\_ t _ -> t) + {-# INLINE grootStrategy #-} + +instance GMergeable arity U1 where + grootStrategy _ = SimpleStrategy (\_ t _ -> t) + {-# INLINE grootStrategy #-} + +instance + (GMergeable arity a, GMergeable arity b) => + GMergeable arity (a :*: b) + where + grootStrategy args = + product2Strategy + (:*:) + (\(a :*: b) -> (a, b)) + (grootStrategy args) + (grootStrategy args) + {-# INLINE grootStrategy #-} + +instance + (GMergeable arity a, GMergeable arity b) => + GMergeable arity (a :+: b) + where + grootStrategy args = + SortedStrategy + ( \case + L1 _ -> False + R1 _ -> True + ) + ( \idx -> + if not idx + then + wrapStrategy + (grootStrategy args) + L1 + (\case (L1 v) -> v; _ -> error "Should not happen") + else + wrapStrategy + (grootStrategy args) + R1 + (\case (R1 v) -> v; _ -> error "Should not happen") + ) + {-# INLINE grootStrategy #-} + +instance (GMergeable arity a) => GMergeable arity (M1 i c a) where + grootStrategy arg = wrapStrategy (grootStrategy arg) M1 unM1 + {-# INLINE grootStrategy #-} + +instance (Mergeable c) => GMergeable arity (K1 i c) where + grootStrategy _ = wrapStrategy rootStrategy K1 unK1 + {-# INLINE grootStrategy #-} + +instance GMergeable Arity1 Par1 where + grootStrategy (MergeableArgs1 strategy) = wrapStrategy strategy Par1 unPar1 + {-# INLINE grootStrategy #-} + +instance (Mergeable1 f) => GMergeable Arity1 (Rec1 f) where + grootStrategy (MergeableArgs1 m) = + wrapStrategy (liftRootStrategy m) Rec1 unRec1 + {-# INLINE grootStrategy #-} + +instance + (Mergeable1 f, GMergeable Arity1 g) => + GMergeable Arity1 (f :.: g) + where + grootStrategy targs = + wrapStrategy (liftRootStrategy (grootStrategy targs)) Comp1 unComp1 + {-# INLINE grootStrategy #-} + +instance (Generic a, GMergeable Arity0 (Rep a)) => Mergeable (Default a) where + rootStrategy = unsafeCoerce (genericRootStrategy :: MergingStrategy a) + {-# INLINE rootStrategy #-} + +-- | Generic 'rootStrategy'. +genericRootStrategy :: + (Generic a, GMergeable Arity0 (Rep a)) => MergingStrategy a +genericRootStrategy = wrapStrategy (grootStrategy MergeableArgs0) to from +{-# INLINE genericRootStrategy #-} + +instance + (Generic1 f, GMergeable Arity1 (Rep1 f), Mergeable a) => + Mergeable (Default1 f a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Generic1 f, GMergeable Arity1 (Rep1 f)) => Mergeable1 (Default1 f) where + liftRootStrategy (m :: MergingStrategy a) = + unsafeCoerce (genericLiftRootStrategy m :: MergingStrategy (f a)) + {-# INLINE liftRootStrategy #-} + +-- | Generic 'liftRootStrategy'. +genericLiftRootStrategy :: + (Generic1 f, GMergeable Arity1 (Rep1 f)) => + MergingStrategy a -> + MergingStrategy (f a) +genericLiftRootStrategy m = + wrapStrategy (grootStrategy $ MergeableArgs1 m) to1 from1 +{-# INLINE genericLiftRootStrategy #-} + +-- | Helper type for combining arbitrary number of indices into one. +-- Useful when trying to write efficient merge strategy for lists/vectors. +data DynamicSortedIdx where + DynamicSortedIdx :: forall idx. (Show idx, Ord idx, Typeable idx) => idx -> DynamicSortedIdx + +instance Eq DynamicSortedIdx where + (DynamicSortedIdx (a :: a)) == (DynamicSortedIdx (b :: b)) = case eqT @a @b of + Just Refl -> a == b + _ -> False + {-# INLINE (==) #-} + +instance Ord DynamicSortedIdx where + compare (DynamicSortedIdx (a :: a)) (DynamicSortedIdx (b :: b)) = case eqT @a @b of + Just Refl -> compare a b + _ -> error "This Ord is incomplete" + {-# INLINE compare #-} + +instance Show DynamicSortedIdx where + show (DynamicSortedIdx a) = show a + +-- | Resolves the indices and the terminal merge strategy for a value of some +-- 'Mergeable' type. +resolveStrategy :: + forall x. + MergingStrategy x -> + x -> + ([DynamicSortedIdx], MergingStrategy x) +resolveStrategy s x = resolveStrategy' x s +{-# INLINE resolveStrategy #-} + +-- | Resolves the indices and the terminal merge strategy for a value given a +-- merge strategy for its type. +resolveStrategy' :: + forall x. x -> MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) +resolveStrategy' x = go + where + go :: MergingStrategy x -> ([DynamicSortedIdx], MergingStrategy x) + go (SortedStrategy idxFun subStrategy) = case go ss of + (idxs, r) -> (DynamicSortedIdx idx : idxs, r) + where + idx = idxFun x + ss = subStrategy idx + go s = ([], s) +{-# INLINE resolveStrategy' #-} + +#define CONCRETE_ORD_MERGEABLE(type) \ +instance Mergeable type where \ + rootStrategy = \ + let sub = SimpleStrategy $ \_ t _ -> t \ + in SortedStrategy id $ const sub + +#define CONCRETE_ORD_MERGEABLE_BV(type) \ +instance (KnownNat n, 1 <= n) => Mergeable (type n) where \ + rootStrategy = \ + let sub = SimpleStrategy $ \_ t _ -> t \ + in SortedStrategy id $ const sub + +#if 1 +CONCRETE_ORD_MERGEABLE(Bool) +CONCRETE_ORD_MERGEABLE(Integer) +CONCRETE_ORD_MERGEABLE(Char) +CONCRETE_ORD_MERGEABLE(Int) +CONCRETE_ORD_MERGEABLE(Int8) +CONCRETE_ORD_MERGEABLE(Int16) +CONCRETE_ORD_MERGEABLE(Int32) +CONCRETE_ORD_MERGEABLE(Int64) +CONCRETE_ORD_MERGEABLE(Word) +CONCRETE_ORD_MERGEABLE(Word8) +CONCRETE_ORD_MERGEABLE(Word16) +CONCRETE_ORD_MERGEABLE(Word32) +CONCRETE_ORD_MERGEABLE(Word64) +CONCRETE_ORD_MERGEABLE(Float) +CONCRETE_ORD_MERGEABLE(Double) +CONCRETE_ORD_MERGEABLE(B.ByteString) +CONCRETE_ORD_MERGEABLE(T.Text) +CONCRETE_ORD_MERGEABLE(FPRoundingMode) +CONCRETE_ORD_MERGEABLE(Monoid.All) +CONCRETE_ORD_MERGEABLE(Monoid.Any) +CONCRETE_ORD_MERGEABLE(Ordering) +CONCRETE_ORD_MERGEABLE_BV(WordN) +CONCRETE_ORD_MERGEABLE_BV(IntN) +#endif + +instance (ValidFP eb sb) => Mergeable (FP eb sb) where + rootStrategy = + let sub = SimpleStrategy $ \_ t _ -> t + in withValidFPProofs @eb @sb + $ SortedStrategy + (\fp -> (bitCast fp :: WordN (eb + sb))) + $ const sub + +#define MERGEABLE_SIMPLE(symtype) \ +instance Mergeable symtype where \ + rootStrategy = SimpleStrategy symIte + +#define MERGEABLE_BV(symtype) \ +instance (KnownNat n, 1 <= n) => Mergeable (symtype n) where \ + rootStrategy = SimpleStrategy symIte + +#define MERGEABLE_FUN(cop, op) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + Mergeable (op sa sb) where \ + rootStrategy = SimpleStrategy symIte + +#if 1 +MERGEABLE_SIMPLE(SymBool) +MERGEABLE_SIMPLE(SymInteger) +MERGEABLE_SIMPLE(SymFPRoundingMode) +MERGEABLE_BV(SymIntN) +MERGEABLE_BV(SymWordN) +MERGEABLE_FUN((=->), (=~>)) +MERGEABLE_FUN((-->), (-~>)) +#endif + +instance (ValidFP eb sb) => Mergeable (SymFP eb sb) where + rootStrategy = SimpleStrategy symIte + +-- function +instance (Mergeable b) => Mergeable (a -> b) where + rootStrategy = case rootStrategy @b of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 ((->) a) where + liftRootStrategy ms = case ms of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE liftRootStrategy #-} + +instance Mergeable2 ((->)) where + liftRootStrategy2 _ ms = case ms of + SimpleStrategy m -> SimpleStrategy $ \cond t f v -> m cond (t v) (f v) + _ -> NoStrategy + {-# INLINE liftRootStrategy2 #-} + +-- Instances +deriveBuiltins + (ViaDefault ''Mergeable) + [''Mergeable] + [ ''Maybe, + ''Either, + ''(), + -- The following three are implemented by hand because they need to be + -- consistent with Mergeable2 instances. + -- ''(,), + -- ''(,,), + -- ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''BitwidthMismatch, + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +deriveBuiltins + (ViaDefault1 ''Mergeable1) + [''Mergeable, ''Mergeable1] + [ ''Maybe, + ''Either, + -- The following three are implemented by hand because they need to be + -- consistent with Mergeable2 instances. + -- ''(,), + -- ''(,,), + -- ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +-- List + +-- | Helper type for building efficient merge strategy for list-like containers. +data StrategyList container where + StrategyList :: + forall a container. + container [DynamicSortedIdx] -> + container (MergingStrategy a) -> + StrategyList container + +-- | Helper function for building efficient merge strategy for list-like +-- containers. +buildStrategyList :: + forall a container. + (Functor container) => + MergingStrategy a -> + container a -> + StrategyList container +buildStrategyList s l = StrategyList idxs strategies + where + r = resolveStrategy s <$> l + idxs = fst <$> r + strategies = snd <$> r +{-# INLINE buildStrategyList #-} + +instance (Eq1 container) => Eq (StrategyList container) where + (StrategyList idxs1 _) == (StrategyList idxs2 _) = eq1 idxs1 idxs2 + {-# INLINE (==) #-} + +instance (Ord1 container) => Ord (StrategyList container) where + compare (StrategyList idxs1 _) (StrategyList idxs2 _) = compare1 idxs1 idxs2 + {-# INLINE compare #-} + +instance (Show1 container) => Show (StrategyList container) where + showsPrec i (StrategyList idxs1 _) = showsPrec1 i idxs1 + {-# INLINE showsPrec #-} + +instance (Mergeable a) => Mergeable [a] where + rootStrategy = case rootStrategy :: MergingStrategy a of + SimpleStrategy m -> + SortedStrategy length $ \_ -> + SimpleStrategy $ \cond -> zipWith (m cond) + NoStrategy -> + SortedStrategy length $ const NoStrategy + _ -> SortedStrategy length $ \_ -> + SortedStrategy (buildStrategyList rootStrategy) $ + \(StrategyList _ strategies) -> + let s :: [MergingStrategy a] = unsafeCoerce strategies + allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s + in if allSimple + then SimpleStrategy $ \cond l r -> + ( \case + (SimpleStrategy f, l1, r1) -> f cond l1 r1 + _ -> error "impossible" + ) + <$> zip3 s l r + else NoStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 [] where + liftRootStrategy (ms :: MergingStrategy a) = case ms of + SimpleStrategy m -> + SortedStrategy length $ \_ -> + SimpleStrategy $ \cond -> zipWith (m cond) + NoStrategy -> + SortedStrategy length $ const NoStrategy + _ -> SortedStrategy length $ \_ -> + SortedStrategy (buildStrategyList ms) $ \(StrategyList _ strategies) -> + let s :: [MergingStrategy a] = unsafeCoerce strategies + allSimple = all (\case SimpleStrategy _ -> True; _ -> False) s + in if allSimple + then SimpleStrategy $ \cond l r -> + ( \case + (SimpleStrategy f, l1, r1) -> f cond l1 r1 + _ -> error "impossible" + ) + <$> zip3 s l r + else NoStrategy + {-# INLINE liftRootStrategy #-} + +-- MaybeT +instance (Mergeable1 m, Mergeable a) => Mergeable (MaybeT m a) where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (MaybeT m) where + liftRootStrategy m = + wrapStrategy (liftRootStrategy (liftRootStrategy m)) MaybeT runMaybeT + {-# INLINE liftRootStrategy #-} + +-- ExceptT +instance + (Mergeable1 m, Mergeable e, Mergeable a) => + Mergeable (ExceptT e m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m, Mergeable e) => Mergeable1 (ExceptT e m) where + liftRootStrategy m = + wrapStrategy (liftRootStrategy (liftRootStrategy m)) ExceptT runExceptT + {-# INLINE liftRootStrategy #-} + +-- state +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (StateLazy.StateT s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable s, Mergeable1 m) => Mergeable1 (StateLazy.StateT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) + StateLazy.StateT + StateLazy.runStateT + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (StateStrict.StateT s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable1 m) => + Mergeable1 (StateStrict.StateT s m) + where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy (liftRootStrategy2 m rootStrategy))) + StateStrict.StateT + StateStrict.runStateT + {-# INLINE liftRootStrategy #-} + +-- writer +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (WriterLazy.WriterT s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable1 m) => + Mergeable1 (WriterLazy.WriterT s m) + where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy2 m rootStrategy)) + WriterLazy.WriterT + WriterLazy.runWriterT + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable a, Mergeable1 m) => + Mergeable (WriterStrict.WriterT s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable1 m) => + Mergeable1 (WriterStrict.WriterT s m) + where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy2 m rootStrategy)) + WriterStrict.WriterT + WriterStrict.runWriterT + {-# INLINE liftRootStrategy #-} + +-- reader +instance + (Mergeable a, Mergeable1 m) => + Mergeable (ReaderT s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (ReaderT s m) where + liftRootStrategy m = + wrapStrategy + (liftRootStrategy (liftRootStrategy m)) + ReaderT + runReaderT + {-# INLINE liftRootStrategy #-} + +-- IdentityT +instance (Mergeable1 m, Mergeable a) => Mergeable (IdentityT m a) where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m) => Mergeable1 (IdentityT m) where + liftRootStrategy m = wrapStrategy (liftRootStrategy m) IdentityT runIdentityT + {-# INLINE liftRootStrategy #-} + +-- ContT +instance (Mergeable1 m, Mergeable r) => Mergeable (ContT r m a) where + rootStrategy = + wrapStrategy + (liftRootStrategy rootStrategy1) + ContT + (\(ContT v) -> v) + {-# INLINE rootStrategy #-} + +instance (Mergeable1 m, Mergeable r) => Mergeable1 (ContT r m) where + liftRootStrategy _ = + wrapStrategy + (liftRootStrategy rootStrategy1) + ContT + (\(ContT v) -> v) + {-# INLINE liftRootStrategy #-} + +-- RWS +instance + (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => + Mergeable (RWSLazy.RWST r w s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable1 m) => + Mergeable1 (RWSLazy.RWST r w s m) + where + liftRootStrategy m = + wrapStrategy + ( liftRootStrategy . liftRootStrategy . liftRootStrategy $ + liftRootStrategy3 m rootStrategy rootStrategy + ) + RWSLazy.RWST + (\(RWSLazy.RWST rws) -> rws) + {-# INLINE liftRootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable a, Mergeable1 m) => + Mergeable (RWSStrict.RWST r w s m a) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance + (Mergeable s, Mergeable w, Mergeable1 m) => + Mergeable1 (RWSStrict.RWST r w s m) + where + liftRootStrategy m = + wrapStrategy + ( liftRootStrategy . liftRootStrategy . liftRootStrategy $ + liftRootStrategy3 m rootStrategy rootStrategy + ) + RWSStrict.RWST + (\(RWSStrict.RWST rws) -> rws) + {-# INLINE liftRootStrategy #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (Mergeable (l a), Mergeable (r a)) => Mergeable (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (Mergeable1 l, Mergeable1 r) => Mergeable1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (Mergeable (l a), Mergeable (r a)) => Mergeable (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (Mergeable1 l, Mergeable1 r) => Mergeable1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (Mergeable (f (g a))) => Mergeable (Compose f g a) + +instance (Mergeable1 f, Mergeable1 g) => Mergeable1 (Compose f g) where + liftRootStrategy s = + wrapStrategy (liftRootStrategy (liftRootStrategy s)) Compose getCompose + {-# INLINE liftRootStrategy #-} + +-- Const +deriving via + (Default (Const a b)) + instance + (Mergeable a) => Mergeable (Const a b) + +deriving via + (Default1 (Const a)) + instance + (Mergeable a) => Mergeable1 (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (Mergeable (f a)) => Mergeable (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (Mergeable1 f) => Mergeable1 (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (Mergeable (f a)) => Mergeable (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (Mergeable1 f) => Mergeable1 (Ap f) + +-- Endo +instance (Mergeable a) => Mergeable (Endo a) where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance Mergeable1 Endo where + liftRootStrategy strategy = + wrapStrategy (liftRootStrategy strategy) Endo appEndo + +-- Generic +deriving via (Default (U1 p)) instance Mergeable (U1 p) + +deriving via (Default (V1 p)) instance Mergeable (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (Mergeable c) => Mergeable (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (Mergeable (f p)) => Mergeable (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (Mergeable (f p), Mergeable (g p)) => Mergeable ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (Mergeable (f p), Mergeable (g p)) => Mergeable ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (Mergeable p) => Mergeable (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (Mergeable (f p)) => Mergeable (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (Mergeable (f (g p))) => Mergeable ((f :.: g) p) + +-- Exceptions +instance Mergeable ArithException where + rootStrategy = + SortedStrategy + ( \case + Overflow -> 0 :: Int + Underflow -> 1 :: Int + LossOfPrecision -> 2 :: Int + DivideByZero -> 3 :: Int + Denormal -> 4 :: Int + RatioZeroDenominator -> 5 :: Int + ) + (const $ SimpleStrategy $ \_ l _ -> l) + +instance Mergeable2 Either where + liftRootStrategy2 m1 m2 = + SortedStrategy + ( \case + Left _ -> False + Right _ -> True + ) + ( \case + False -> wrapStrategy m1 Left (\case (Left v) -> v; _ -> undefined) + True -> wrapStrategy m2 Right (\case (Right v) -> v; _ -> undefined) + ) + {-# INLINE liftRootStrategy2 #-} + +-- (,) +instance (Mergeable a, Mergeable b) => Mergeable (a, b) where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable a) => Mergeable1 ((,) a) where + liftRootStrategy = liftRootStrategy2 rootStrategy + {-# INLINE liftRootStrategy #-} + +instance Mergeable2 (,) where + liftRootStrategy2 = product2Strategy (,) id + {-# INLINE liftRootStrategy2 #-} + +-- (,,) +instance (Mergeable a, Mergeable b, Mergeable c) => Mergeable ((,,) a b c) where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance (Mergeable a, Mergeable b) => Mergeable1 ((,,) a b) where + liftRootStrategy = liftRootStrategy2 rootStrategy + {-# INLINE liftRootStrategy #-} + +instance (Mergeable a) => Mergeable2 ((,,) a) where + liftRootStrategy2 = liftRootStrategy3 rootStrategy + {-# INLINE liftRootStrategy2 #-} + +instance Mergeable3 (,,) where + liftRootStrategy3 m1 m2 m3 = + product2Strategy + (\a (b, c) -> (a, b, c)) + (\(a, b, c) -> (a, (b, c))) + m1 + (liftRootStrategy2 m2 m3) + {-# INLINE liftRootStrategy3 #-} + +-- (,,,) +instance + (Mergeable a, Mergeable b, Mergeable c, Mergeable d) => + Mergeable ((,,,) a b c d) + where + rootStrategy = rootStrategy1 + {-# INLINE rootStrategy #-} + +instance + (Mergeable a, Mergeable b, Mergeable c) => + Mergeable1 ((,,,) a b c) + where + liftRootStrategy = liftRootStrategy2 rootStrategy + {-# INLINE liftRootStrategy #-} + +instance (Mergeable a, Mergeable b) => Mergeable2 ((,,,) a b) where + liftRootStrategy2 = liftRootStrategy3 rootStrategy + {-# INLINE liftRootStrategy2 #-} + +instance (Mergeable a) => Mergeable3 ((,,,) a) where + liftRootStrategy3 m1 m2 m3 = + product2Strategy + (\(a, b) (c, d) -> (a, b, c, d)) + (\(a, b, c, d) -> ((a, b), (c, d))) + (liftRootStrategy m1) + (liftRootStrategy2 m2 m3) + {-# INLINE liftRootStrategy3 #-} diff --git a/src/Grisette/Internal/Core/Data/Class/PPrint.hs b/src/Grisette/Internal/Core/Data/Class/PPrint.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/PPrint.hs @@ -0,0 +1,858 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.PPrint +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.PPrint + ( -- * Pretty printing + PPrint (..), + docToTextWith, + docToTextWithWidth, + docToText, + pformatTextWith, + pformatTextWithWidth, + pformatText, + pprint, + PPrint1 (..), + pformatPrec1, + pformatList1, + PPrint2 (..), + pformatPrec2, + pformatList2, + + -- * Generic 'PPrint' + genericPFormatPrec, + genericLiftPFormatPrec, + genericPFormatList, + genericLiftPFormatList, + PPrintArgs (..), + GPPrint (..), + PPrintType (..), + + -- * Helpers + groupedEnclose, + condEnclose, + pformatWithConstructor, + pformatWithConstructorNoAlign, + viaShowsPrec, + + -- * Re-exports + module Prettyprinter, + ) +where + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter +import Prettyprinter.Render.String (renderString) +import Prettyprinter.Render.Text (renderStrict) +#else +import Data.Text.Prettyprint.Doc as Prettyprinter +import Data.Text.Prettyprint.Doc.Render.String (renderString) +import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) +#endif + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import Data.String (IsString (fromString)) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics + ( C1, + Constructor (conFixity, conIsRecord, conName), + D1, + Fixity (Infix, Prefix), + Generic (Rep, from), + Generic1 (Rep1, from1), + K1 (K1), + M1 (M1), + Par1 (Par1, unPar1), + Rec1 (Rec1, unRec1), + S1, + Selector (selName), + U1 (U1), + V1, + (:.:) (Comp1, unComp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import GHC.Stack (HasCallStack) +import GHC.TypeLits (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default, unDefault), + Default1 (Default1, unDefault1), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep, + SupportedPrim, + prettyPrintTerm, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- | Pretty printing of values. +-- +-- This class is similar to the 'Pretty' class from the "Prettyprinter" package, +-- but it also provides pretty printing with a given precedence level. +-- +-- We are able to derive instances of this class for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving PPrint via (Default X) +-- +-- The derived instance will pretty print the value with a format similar to the +-- one used by ormolu. +class PPrint a where + pformat :: a -> Doc ann + pformatPrec :: Int -> a -> Doc ann + pformatList :: [a] -> Doc ann + pformatList = align . prettyPrintList . map pformat + + pformat = pformatPrec 0 + pformatPrec _ = pformat + + {-# MINIMAL pformat | pformatPrec #-} + +prettyPrintList :: [Doc ann] -> Doc ann +prettyPrintList l + | null l = "[]" + | length l == 1 = align $ group $ vcat ["[" <> flatAlt " " "" <> head l, "]"] + | otherwise = + groupedEnclose "[" "]" . align . vcat $ + ((\v -> v <> flatAlt "," ", ") <$> init l) ++ [last l] + +prettyPrintTuple :: [Doc ann] -> Doc ann +prettyPrintTuple l + | length l >= 2 = + groupedEnclose "(" ")" . align . vcat $ + ((\v -> v <> flatAlt "," ", ") <$> init l) ++ [last l] + | otherwise = error "Tuple must have at least 2 elements" + +instance PPrint Char where + pformat = viaShow + pformatList v = pretty (fromString v :: T.Text) + +instance (PPrint a) => PPrint [a] where + pformat = pformatList + +-- | Convenience function to layout and render a 'Doc' to 'T.Text'. +-- +-- You can control the layout with 'LayoutOptions'. +docToTextWith :: LayoutOptions -> Doc ann -> T.Text +docToTextWith options = renderStrict . layoutPretty options + +-- | Convenience function to layout and render a 'Doc' to 'T.Text'. +-- +-- You can control the layout with a single number of the width limit. +docToTextWithWidth :: Int -> Doc ann -> T.Text +docToTextWithWidth n + | n <= 0 = docToTextWith (LayoutOptions Unbounded) + | otherwise = docToTextWith (LayoutOptions $ AvailablePerLine n 1.0) + +-- | Convenience function to layout and render a 'Doc' to 'T.Text'. +-- +-- The default layout options 'defaultLayoutOptions' are used. +docToText :: Doc ann -> T.Text +docToText = docToTextWith defaultLayoutOptions + +-- | Convenience function to format a value to 'T.Text'. +-- +-- You can control the layout with 'LayoutOptions'. +pformatTextWith :: (PPrint a) => LayoutOptions -> a -> T.Text +pformatTextWith options = docToTextWith options . pformat + +-- | Convenience function to format a value to 'T.Text'. +-- +-- You can control the layout with a single number of the width limit. +pformatTextWithWidth :: (PPrint a) => Int -> a -> T.Text +pformatTextWithWidth n = docToTextWithWidth n . pformat + +-- | Convenience function to format a value to 'T.Text'. +-- +-- The default layout options 'defaultLayoutOptions' are used. +pformatText :: (PPrint a) => a -> T.Text +pformatText = docToText . pformat + +-- | Pretty print a value to the standard output. +pprint :: (PPrint a) => a -> IO () +pprint = putStrLn . renderString . layoutPretty defaultLayoutOptions . pformat + +-- | Lifting of the 'PPrint' class to unary type constructors. +class (forall a. (PPrint a) => PPrint (f a)) => PPrint1 f where + -- | Lift a pretty-printer to a unary type constructor. + liftPFormatPrec :: + (Int -> a -> Doc ann) -> ([a] -> Doc ann) -> Int -> f a -> Doc ann + + -- | Lift a pretty-printer to list of values with unary type constructors. + liftPFormatList :: + (Int -> a -> Doc ann) -> ([a] -> Doc ann) -> [f a] -> Doc ann + liftPFormatList f l = align . prettyPrintList . map (liftPFormatPrec f l 0) + +instance PPrint1 [] where + liftPFormatPrec _ l _ = l + liftPFormatList _ l = prettyPrintList . fmap l + +-- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to unary +-- type constructors. +pformatPrec1 :: (PPrint1 f, PPrint a) => Int -> f a -> Doc ann +pformatPrec1 = liftPFormatPrec pformatPrec pformatList +{-# INLINE pformatPrec1 #-} + +-- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to list of +-- values with unary type constructors. +pformatList1 :: (PPrint1 f, PPrint a) => [f a] -> Doc ann +pformatList1 = liftPFormatList pformatPrec pformatList +{-# INLINE pformatList1 #-} + +-- | Lifting of the 'PPrint' class to binary type constructors. +class + ( forall a. (PPrint a) => PPrint1 (f a), + forall a b. (PPrint a, PPrint b) => PPrint (f a b) + ) => + PPrint2 f + where + -- | Lift two pretty-printers to a binary type constructor. + liftPFormatPrec2 :: + (Int -> a -> Doc ann) -> + (Int -> b -> Doc ann) -> + ([a] -> Doc ann) -> + ([b] -> Doc ann) -> + Int -> + f a b -> + Doc ann + + -- | Lift two pretty-printers to list of values with binary type constructors. + liftPFormatList2 :: + (Int -> a -> Doc ann) -> + (Int -> b -> Doc ann) -> + ([a] -> Doc ann) -> + ([b] -> Doc ann) -> + [f a b] -> + Doc ann + liftPFormatList2 fa fb la lb = + align . prettyPrintList . map (liftPFormatPrec2 fa fb la lb 0) + +-- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to binary +-- type constructors. +pformatPrec2 :: (PPrint2 f, PPrint a, PPrint b) => Int -> f a b -> Doc ann +pformatPrec2 = liftPFormatPrec2 pformatPrec pformatPrec pformatList pformatList +{-# INLINE pformatPrec2 #-} + +-- | Lift the standard pretty-printer ('pformatPrec', 'pformatList') to list of +-- values with binary type constructors. +pformatList2 :: (PPrint2 f, PPrint a, PPrint b) => [f a b] -> Doc ann +pformatList2 = liftPFormatList2 pformatPrec pformatPrec pformatList pformatList +{-# INLINE pformatList2 #-} + +-- | The arguments to the generic 'PPrint' class. +data family PPrintArgs arity a ann :: Type + +data instance PPrintArgs Arity0 _ _ = PPrintArgs0 + +data instance PPrintArgs Arity1 a ann + = PPrintArgs1 + ((Int -> a -> Doc ann)) + (([a] -> Doc ann)) + +-- | Controls how to pretty-print a generic representation. +data PPrintType = Rec | Tup | Pref | Inf String Int + deriving (Show, Eq) + +-- | Enclose a document with left and right documents. +-- +-- The pretty printer will try to layout the document in a single line, but the +-- right document may be split to a newline. +groupedEnclose :: Doc ann -> Doc ann -> Doc ann -> Doc ann +groupedEnclose l r d = group $ align $ vcat [l <> flatAlt " " "" <> align d, r] + +-- | Conditionally enclose a document with left and right documents. +-- +-- If the condition is 'True', then this function is equivalent to +-- 'groupedEnclose'. +condEnclose :: Bool -> Doc ann -> Doc ann -> Doc ann -> Doc ann +condEnclose b = if b then groupedEnclose else const $ const id + +-- | Pretty print a list of fields with a constructor. +-- +-- Aligns the fields and nests them by 2 spaces. +pformatWithConstructor :: Int -> Doc ann -> [Doc ann] -> Doc ann +pformatWithConstructor n c l = + group $ condEnclose (n > 10) "(" ")" $ align $ nest 2 $ vsep (c : l) + +-- | Pretty print a list of fields with a constructor without alignment. +pformatWithConstructorNoAlign :: Int -> Doc ann -> [Doc ann] -> Doc ann +pformatWithConstructorNoAlign n c l = + group $ condEnclose (n > 10) "(" ")" $ nest 2 $ vsep (c : l) + +-- | Pretty print a value using 'showsPrec'. +viaShowsPrec :: (Int -> a -> ShowS) -> Int -> a -> Doc ann +viaShowsPrec f n a = pretty (f n a "") + +-- | Generic 'PPrint' class. +class GPPrint arity f where + gpformatPrec :: PPrintArgs arity a ann -> PPrintType -> Int -> f a -> Doc ann + gpformatList :: (HasCallStack) => PPrintArgs arity a ann -> [f a] -> Doc ann + gpformatList = error "generic format (gpformatList): unnecessary case" + gisNullary :: (HasCallStack) => PPrintArgs arity a ann -> f a -> Bool + gisNullary = error "generic format (isNullary): unnecessary case" + +instance GPPrint arity V1 where + gpformatPrec _ _ _ x = case x of {} + +instance GPPrint arity U1 where + gpformatPrec _ _ _ U1 = "" + gisNullary _ _ = True + +instance (PPrint c) => GPPrint arity (K1 i c) where + gpformatPrec _ _ n (K1 a) = pformatPrec n a + gisNullary _ _ = False + +instance (GPPrint arity a, Constructor c) => GPPrint arity (C1 c a) where + gpformatPrec arg _ n c@(M1 x) = + case t of + Tup -> + prettyBraces t (gpformatPrec arg t 0 x) + Inf _ m -> + group $ condEnclose (n > m) "(" ")" $ gpformatPrec arg t m x + _ -> + if gisNullary arg x + then pformat (conName c) + else + pformatWithConstructorNoAlign + n + (pformat (conName c)) + [prettyBraces t (gpformatPrec arg t 11 x)] + where + prettyBraces :: PPrintType -> Doc ann -> Doc ann + prettyBraces Rec = groupedEnclose "{" "}" + prettyBraces Tup = groupedEnclose "(" ")" + prettyBraces Pref = id + prettyBraces (Inf _ _) = id + fixity = conFixity c + t + | conIsRecord c = Rec + | conIsTuple c = Tup + | otherwise = case fixity of + Prefix -> Pref + Infix _ i -> Inf (conName c) i + conIsTuple :: C1 c f p -> Bool + conIsTuple y = tupleName (conName y) + where + tupleName ('(' : ',' : _) = True + tupleName _ = False + +instance (Selector s, GPPrint arity a) => GPPrint arity (S1 s a) where + gpformatPrec arg t n s@(M1 x) + | selName s == "" = + case t of + Pref -> gpformatPrec arg t (n + 1) x + _ -> gpformatPrec arg t (n + 1) x + | otherwise = + group $ + align $ + nest 2 $ + vsep [pretty (selName s) <+> "=", gpformatPrec arg t 0 x] + gisNullary _ _ = False + +instance (GPPrint arity a) => GPPrint arity (D1 d a) where + gpformatPrec arg _ n (M1 x) = gpformatPrec arg Pref n x + gpformatList arg = align . prettyPrintList . fmap (gpformatPrec arg Pref 0) + +instance (GPPrint arity a, GPPrint arity b) => GPPrint arity (a :+: b) where + gpformatPrec arg t n (L1 x) = gpformatPrec arg t n x + gpformatPrec arg t n (R1 x) = gpformatPrec arg t n x + +instance (GPPrint arity a, GPPrint arity b) => GPPrint arity (a :*: b) where + gpformatPrec arg t@Rec n (a :*: b) = + align $ + vcat + [ gpformatPrec arg t n a <> "," <> flatAlt "" " ", + gpformatPrec arg t n b + ] + gpformatPrec arg t@(Inf s _) n (a :*: b) = + nest 2 $ + vsep + [ align $ gpformatPrec arg t n a, + pretty s <+> gpformatPrec arg t n b + ] + gpformatPrec arg t@Tup _ (a :*: b) = + vcat + [ gpformatPrec arg t 0 a <> "," <> flatAlt "" " ", + gpformatPrec arg t 0 b + ] + gpformatPrec arg t@Pref n (a :*: b) = + vsep + [ gpformatPrec arg t (n + 1) a, + gpformatPrec arg t (n + 1) b + ] + gisNullary _ _ = False + +instance GPPrint Arity1 Par1 where + gpformatPrec (PPrintArgs1 f _) _ n (Par1 a) = f n a + gpformatList (PPrintArgs1 _ g) l = g $ unPar1 <$> l + +instance (PPrint1 f) => GPPrint Arity1 (Rec1 f) where + gpformatPrec (PPrintArgs1 f g) _ n (Rec1 x) = liftPFormatPrec f g n x + gpformatList (PPrintArgs1 f g) l = liftPFormatList f g $ unRec1 <$> l + +instance + (PPrint1 f, GPPrint Arity1 g) => + GPPrint Arity1 (f :.: g) + where + gpformatPrec arg t n (Comp1 x) = + liftPFormatPrec (gpformatPrec arg t) (gpformatList arg) n x + gpformatList arg l = + liftPFormatList (gpformatPrec arg Pref) (gpformatList arg) $ unComp1 <$> l + +-- | Generic 'pformatPrec' function. +genericPFormatPrec :: + (Generic a, GPPrint Arity0 (Rep a)) => + Int -> + a -> + Doc ann +genericPFormatPrec n = gpformatPrec PPrintArgs0 Pref n . from +{-# INLINE genericPFormatPrec #-} + +-- | Generic 'pformatList' function. +genericPFormatList :: + (Generic a, GPPrint Arity0 (Rep a)) => + [a] -> + Doc ann +genericPFormatList = gpformatList PPrintArgs0 . fmap from +{-# INLINE genericPFormatList #-} + +-- | Generic 'liftPFormatPrec' function. +genericLiftPFormatPrec :: + (Generic1 f, GPPrint Arity1 (Rep1 f)) => + (Int -> a -> Doc ann) -> + ([a] -> Doc ann) -> + Int -> + f a -> + Doc ann +genericLiftPFormatPrec p l n = gpformatPrec (PPrintArgs1 p l) Pref n . from1 +{-# INLINE genericLiftPFormatPrec #-} + +-- | Generic 'liftPFormatList' function. +genericLiftPFormatList :: + (Generic1 f, GPPrint Arity1 (Rep1 f)) => + (Int -> a -> Doc ann) -> + ([a] -> Doc ann) -> + [f a] -> + Doc ann +genericLiftPFormatList p l = gpformatList (PPrintArgs1 p l) . fmap from1 +{-# INLINE genericLiftPFormatList #-} + +instance + (Generic a, GPPrint Arity0 (Rep a)) => + PPrint (Default a) + where + pformatPrec n = genericPFormatPrec n . unDefault + pformatList = genericPFormatList . fmap unDefault + +instance + (Generic1 f, GPPrint Arity1 (Rep1 f), PPrint a) => + PPrint (Default1 f a) + where + pformatPrec = pformatPrec1 + pformatList = pformatList1 + +instance + (Generic1 f, GPPrint Arity1 (Rep1 f)) => + PPrint1 (Default1 f) + where + liftPFormatPrec p l n = genericLiftPFormatPrec p l n . unDefault1 + liftPFormatList p l = genericLiftPFormatList p l . fmap unDefault1 + +#define FORMAT_SIMPLE(type) \ +instance PPrint type where pformatPrec = viaShowsPrec showsPrec + +#if 1 +FORMAT_SIMPLE(Bool) +FORMAT_SIMPLE(Integer) +FORMAT_SIMPLE(Int) +FORMAT_SIMPLE(Int8) +FORMAT_SIMPLE(Int16) +FORMAT_SIMPLE(Int32) +FORMAT_SIMPLE(Int64) +FORMAT_SIMPLE(Word) +FORMAT_SIMPLE(Word8) +FORMAT_SIMPLE(Word16) +FORMAT_SIMPLE(Word32) +FORMAT_SIMPLE(Word64) +FORMAT_SIMPLE(Float) +FORMAT_SIMPLE(Double) +FORMAT_SIMPLE(FPRoundingMode) +FORMAT_SIMPLE(Monoid.All) +FORMAT_SIMPLE(Monoid.Any) +FORMAT_SIMPLE(Ordering) +#endif + +instance PPrint B.ByteString where + pformat = pretty . C.unpack + +instance PPrint T.Text where + pformat = pretty + +instance (KnownNat n, 1 <= n) => PPrint (IntN n) where + pformat = viaShow + +instance (KnownNat n, 1 <= n) => PPrint (WordN n) where + pformat = viaShow + +instance (ValidFP eb sb) => PPrint (FP eb sb) where + pformat = viaShow + +-- Prettyprint +#define FORMAT_SYM_SIMPLE(symtype) \ +instance PPrint symtype where \ + pformat (symtype t) = prettyPrintTerm t + +#define FORMAT_SYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => PPrint (symtype n) where \ + pformat (symtype t) = prettyPrintTerm t + +#define FORMAT_SYM_FUN(op, cons) \ +instance (SupportedPrim ca, SupportedPrim cb, LinkedRep ca sa, LinkedRep cb sb)\ + => PPrint (sa op sb) where \ + pformat (cons t) = prettyPrintTerm t + +#if 1 +FORMAT_SYM_SIMPLE(SymBool) +FORMAT_SYM_SIMPLE(SymInteger) +FORMAT_SYM_SIMPLE(SymFPRoundingMode) +FORMAT_SYM_BV(SymIntN) +FORMAT_SYM_BV(SymWordN) +FORMAT_SYM_FUN(=~>, SymTabularFun) +FORMAT_SYM_FUN(-~>, SymGeneralFun) +#endif + +instance (ValidFP eb sb) => PPrint (SymFP eb sb) where + pformat (SymFP t) = prettyPrintTerm t + +-- Instance +deriveBuiltins + (ViaDefault ''PPrint) + [''PPrint] + [ ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +deriveBuiltins + (ViaDefault1 ''PPrint1) + [''PPrint, ''PPrint1] + [ ''Maybe, + ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +-- Identity +instance (PPrint a) => PPrint (Identity a) where + pformatPrec = pformatPrec1 + +instance PPrint1 Identity where + liftPFormatPrec f _ n (Identity a) = + pformatWithConstructor n "Identity" [f 11 a] + +-- MaybeT +instance + (PPrint1 m, PPrint a) => + PPrint (MaybeT m a) + where + pformatPrec = pformatPrec1 + +instance + (PPrint1 m) => + PPrint1 (MaybeT m) + where + liftPFormatPrec f l n (MaybeT a) = + pformatWithConstructor + n + "MaybeT" + [liftPFormatPrec (liftPFormatPrec f l) (liftPFormatList f l) 11 a] + +-- ExceptT +instance + (PPrint1 m, PPrint e, PPrint a) => + PPrint (ExceptT e m a) + where + pformatPrec = pformatPrec1 + +instance + (PPrint1 m, PPrint e) => + PPrint1 (ExceptT e m) + where + liftPFormatPrec f l n (ExceptT a) = + pformatWithConstructor + n + "ExceptT" + [liftPFormatPrec (liftPFormatPrec f l) (liftPFormatList f l) 11 a] + +-- WriterT +instance + (PPrint1 m, PPrint a, PPrint w) => + PPrint (WriterLazy.WriterT w m a) + where + pformatPrec = pformatPrec1 + +instance + (PPrint1 m, PPrint w) => + PPrint1 (WriterLazy.WriterT w m) + where + liftPFormatPrec f l n (WriterLazy.WriterT a) = + pformatWithConstructor + n + "WriterT" + [ liftPFormatPrec + (liftPFormatPrec2 f pformatPrec l pformatList) + (liftPFormatList2 f pformatPrec l pformatList) + 11 + a + ] + +instance + (PPrint1 m, PPrint a, PPrint w) => + PPrint (WriterStrict.WriterT w m a) + where + pformatPrec = pformatPrec1 + +instance + (PPrint1 m, PPrint w) => + PPrint1 (WriterStrict.WriterT w m) + where + liftPFormatPrec f l n (WriterStrict.WriterT a) = + pformatWithConstructor + n + "WriterT" + [ liftPFormatPrec + (liftPFormatPrec2 f pformatPrec l pformatList) + (liftPFormatList2 f pformatPrec l pformatList) + 11 + a + ] + +-- IdentityT +instance (PPrint1 m, PPrint a) => PPrint (IdentityT m a) where + pformatPrec = pformatPrec1 + +instance (PPrint1 m) => PPrint1 (IdentityT m) where + liftPFormatPrec f l n (IdentityT a) = + pformatWithConstructor n "IdentityT" [liftPFormatPrec f l 11 a] + +-- Product +deriving via + (Default (Product l r a)) + instance + (PPrint (l a), PPrint (r a)) => PPrint (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (PPrint1 l, PPrint1 r) => PPrint1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (PPrint (l a), PPrint (r a)) => PPrint (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (PPrint1 l, PPrint1 r) => PPrint1 (Sum l r) + +-- Compose +instance (PPrint (f (g a))) => PPrint (Compose f g a) where + pformatPrec n (Compose a) = + pformatWithConstructor n "Compose" [pformatPrec 11 a] + +instance (PPrint1 f, PPrint1 g) => PPrint1 (Compose f g) where + liftPFormatPrec f l n (Compose a) = + pformatWithConstructor + n + "Compose" + [liftPFormatPrec (liftPFormatPrec f l) (liftPFormatList f l) 11 a] + +-- Const +deriving via (Default (Const a b)) instance (PPrint a) => PPrint (Const a b) + +deriving via (Default1 (Const a)) instance (PPrint a) => PPrint1 (Const a) + +-- Alt +deriving via (Default (Alt f a)) instance (PPrint (f a)) => PPrint (Alt f a) + +deriving via (Default1 (Alt f)) instance (PPrint1 f) => PPrint1 (Alt f) + +-- Ap +deriving via (Default (Ap f a)) instance (PPrint (f a)) => PPrint (Ap f a) + +deriving via (Default1 (Ap f)) instance (PPrint1 f) => PPrint1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance PPrint (U1 p) + +deriving via (Default (V1 p)) instance PPrint (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (PPrint c) => PPrint (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (PPrint (f p)) => PPrint (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (PPrint (f p), PPrint (g p)) => PPrint ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (PPrint (f p), PPrint (g p)) => PPrint ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (PPrint p) => PPrint (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (PPrint (f p)) => PPrint (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (PPrint (f (g p))) => PPrint ((f :.: g) p) + +-- PPrint2 +instance PPrint2 Either where + liftPFormatPrec2 fe _ _ _ n (Left e) = + pformatWithConstructor n "Left" [fe 11 e] + liftPFormatPrec2 _ fa _ _ n (Right a) = + pformatWithConstructor n "Right" [fa 11 a] + +instance PPrint2 (,) where + liftPFormatPrec2 fa fb _ _ _ (a, b) = + prettyPrintTuple [fa 0 a, fb 0 b] + +instance (PPrint a) => PPrint2 ((,,) a) where + liftPFormatPrec2 fb fc _ _ _ (a, b, c) = + prettyPrintTuple [pformat a, fb 0 b, fc 0 c] + +instance (PPrint a, PPrint b) => PPrint2 ((,,,) a b) where + liftPFormatPrec2 fc fd _ _ _ (a, b, c, d) = + prettyPrintTuple [pformat a, pformat b, fc 0 c, fd 0 d] + +instance (PPrint a) => PPrint (HS.HashSet a) where + pformatPrec n s = + pformatWithConstructor n "fromList" [pformatPrec 11 $ HS.toList s] + +instance (PPrint k, PPrint v) => PPrint (HM.HashMap k v) where + pformatPrec n s = + pformatWithConstructor n "fromList" [pformatPrec 11 $ HM.toList s] diff --git a/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs b/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs --- a/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs +++ b/src/Grisette/Internal/Core/Data/Class/PlainUnion.hs @@ -40,7 +40,7 @@ import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) import Grisette.Internal.Core.Data.Class.SimpleMergeable ( SimpleMergeable, - UnionMergeable1, + SymBranching, mrgIf, ) import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) @@ -56,28 +56,28 @@ -- | Plain union containers that can be projected back into single value or -- if-guarded values. -class (Applicative u, UnionMergeable1 u) => PlainUnion (u :: Type -> Type) where +class (Applicative u, SymBranching u) => PlainUnion (u :: Type -> Type) where -- | Pattern match to extract single values. -- - -- >>> singleView (return 1 :: UnionM Integer) + -- >>> singleView (return 1 :: Union Integer) -- Just 1 - -- >>> singleView (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: UnionM Integer) + -- >>> singleView (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: Union Integer) -- Nothing singleView :: u a -> Maybe a -- | Pattern match to extract if values. -- - -- >>> ifView (return 1 :: UnionM Integer) + -- >>> ifView (return 1 :: Union Integer) -- Nothing - -- >>> ifView (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: UnionM Integer) + -- >>> ifView (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: Union Integer) -- Just (a,<1>,<2>) - -- >>> ifView (mrgIf "a" (return 1) (return 2) :: UnionM Integer) + -- >>> ifView (mrgIf "a" (return 1) (return 2) :: Union Integer) -- Just (a,{1},{2}) ifView :: u a -> Maybe (SymBool, u a, u a) -- | Convert the union to a guarded list. -- - -- >>> toGuardedList (mrgIf "a" (return 1) (mrgIf "b" (return 2) (return 3)) :: UnionM Integer) + -- >>> toGuardedList (mrgIf "a" (return 1) (mrgIf "b" (return 2) (return 3)) :: Union Integer) -- [(a,1),((&& b (! a)),2),((! (|| b a)),3)] toGuardedList :: u a -> [(SymBool, a)] toGuardedList u = @@ -90,10 +90,10 @@ -- | Return all possible values in the union. Drop the path conditions. -- - -- >>> overestimateUnionValues (return 1 :: UnionM Integer) + -- >>> overestimateUnionValues (return 1 :: Union Integer) -- [1] -- - -- >>> overestimateUnionValues (mrgIf "a" (return 1) (return 2) :: UnionM Integer) + -- >>> overestimateUnionValues (mrgIf "a" (return 1) (return 2) :: Union Integer) -- [1,2] overestimateUnionValues :: (Mergeable a) => u a -> [a] overestimateUnionValues (Single v) = [v] @@ -102,7 +102,7 @@ -- | Pattern match to extract single values with 'singleView'. -- --- >>> case (return 1 :: UnionM Integer) of Single v -> v +-- >>> case (return 1 :: Union Integer) of Single v -> v -- 1 pattern Single :: (PlainUnion u, Mergeable a) => a -> u a pattern Single x <- @@ -111,7 +111,8 @@ Single x = mrgSingle x -- | Pattern match to extract guard values with 'ifView' --- >>> case (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: UnionM Integer) of If c t f -> (c,t,f) +-- +-- >>> case (mrgIfPropagatedStrategy "a" (return 1) (return 2) :: Union Integer) of If c t f -> (c,t,f) -- (a,<1>,<2>) pattern If :: (PlainUnion u, Mergeable a) => SymBool -> u a -> u a -> u a pattern If c t f <- @@ -125,12 +126,14 @@ -- | Merge the simply mergeable values in a union, and extract the merged value. -- --- In the following example, 'mrgIfPropagatedStrategy' will not merge the results, and --- 'simpleMerge' will merge it and extract the single merged value. +-- In the following example, +-- 'Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIfPropagatedStrategy' +-- will not merge the results, and 'simpleMerge' will merge it and extract the +-- single merged value. -- --- >>> mrgIfPropagatedStrategy (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool +-- >>> mrgIfPropagatedStrategy (ssym "a") (return $ ssym "b") (return $ ssym "c") :: Union SymBool -- --- >>> simpleMerge $ (mrgIfPropagatedStrategy (ssym "a") (return $ ssym "b") (return $ ssym "c") :: UnionM SymBool) +-- >>> simpleMerge $ (mrgIfPropagatedStrategy (ssym "a") (return $ ssym "b") (return $ ssym "c") :: Union SymBool) -- (ite a b c) simpleMerge :: forall u a. (SimpleMergeable a, PlainUnion u) => u a -> a simpleMerge u = case tryMerge u of @@ -149,10 +152,10 @@ symIteMerge (If cond l r) = symIte cond (symIteMerge l) (symIteMerge r) {-# INLINE symIteMerge #-} --- | Helper for applying functions on 'UnionLike' and 'SimpleMergeable'. +-- | Helper for applying functions on 'PlainUnion' and 'SimpleMergeable'. -- --- >>> let f :: Integer -> UnionM Integer = \x -> mrgIf (ssym "a") (mrgSingle $ x + 1) (mrgSingle $ x + 2) --- >>> f .# (mrgIf (ssym "b" :: SymBool) (mrgSingle 0) (mrgSingle 2) :: UnionM Integer) +-- >>> let f :: Integer -> Union Integer = \x -> mrgIf (ssym "a") (mrgSingle $ x + 1) (mrgSingle $ x + 2) +-- >>> f .# (mrgIf (ssym "b" :: SymBool) (mrgSingle 0) (mrgSingle 2) :: Union Integer) -- {If (&& b a) 1 (If b 2 (If a 3 4))} (.#) :: (Function f a r, SimpleMergeable r, PlainUnion u) => @@ -166,12 +169,12 @@ -- | Lift a function to work on union values. -- --- >>> sumU = onUnion sum --- >>> sumU (mrgIfPropagatedStrategy "cond" (return ["a"]) (return ["b","c"]) :: UnionM [SymInteger]) +-- >>> sumU = onUnion sum :: Union [SymInteger] -> SymInteger +-- >>> sumU (mrgIfPropagatedStrategy "cond" (return ["a"]) (return ["b","c"]) :: Union [SymInteger]) -- (ite cond a (+ b c)) onUnion :: forall u a r. - (SimpleMergeable r, UnionMergeable1 u, PlainUnion u, Mergeable a) => + (SimpleMergeable r, SymBranching u, PlainUnion u, Mergeable a) => (a -> r) -> (u a -> r) onUnion f = simpleMerge . fmap f . tryMerge @@ -180,7 +183,7 @@ onUnion2 :: forall u a b r. ( SimpleMergeable r, - UnionMergeable1 u, + SymBranching u, PlainUnion u, Mergeable a, Mergeable b @@ -193,7 +196,7 @@ onUnion3 :: forall u a b c r. ( SimpleMergeable r, - UnionMergeable1 u, + SymBranching u, PlainUnion u, Mergeable a, Mergeable b, @@ -208,7 +211,7 @@ onUnion4 :: forall u a b c d r. ( SimpleMergeable r, - UnionMergeable1 u, + SymBranching u, PlainUnion u, Mergeable a, Mergeable b, diff --git a/src/Grisette/Internal/Core/Data/Class/SEq.hs b/src/Grisette/Internal/Core/Data/Class/SEq.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core/Data/Class/SEq.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Internal.Core.Data.Class.Bool --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.Data.Class.SEq - ( -- * Symbolic equality - SEq (..), - SEq' (..), - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default), - Generic (Rep, from), - K1 (K1), - M1 (M1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Internal.Core.Control.Exception - ( AssertionError, - VerificationConditions, - ) -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.SymPrim.Prim.Term (pevalEqTerm) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> :set -XDataKinds --- >>> :set -XBinaryLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XFlexibleInstances --- >>> :set -XFunctionalDependencies - --- | Symbolic equality. Note that we can't use Haskell's 'Eq' class since --- symbolic comparison won't necessarily return a concrete 'Bool' value. --- --- >>> let a = 1 :: SymInteger --- >>> let b = 2 :: SymInteger --- >>> a .== b --- false --- >>> a ./= b --- true --- --- >>> let a = "a" :: SymInteger --- >>> let b = "b" :: SymInteger --- >>> a ./= b --- (! (= a b)) --- >>> a ./= b --- (! (= a b)) --- --- __Note:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving SEq via (Default X) -class SEq a where - (.==) :: a -> a -> SymBool - a .== b = symNot $ a ./= b - {-# INLINE (.==) #-} - infix 4 .== - - (./=) :: a -> a -> SymBool - a ./= b = symNot $ a .== b - {-# INLINE (./=) #-} - infix 4 ./= - {-# MINIMAL (.==) | (./=) #-} - --- SEq instances -#define CONCRETE_SEQ(type) \ -instance SEq type where \ - l .== r = con $ l == r; \ - {-# INLINE (.==) #-} - -#define CONCRETE_SEQ_BV(type) \ -instance (KnownNat n, 1 <= n) => SEq (type n) where \ - l .== r = con $ l == r; \ - {-# INLINE (.==) #-} - -#if 1 -CONCRETE_SEQ(Bool) -CONCRETE_SEQ(Integer) -CONCRETE_SEQ(Char) -CONCRETE_SEQ(Int) -CONCRETE_SEQ(Int8) -CONCRETE_SEQ(Int16) -CONCRETE_SEQ(Int32) -CONCRETE_SEQ(Int64) -CONCRETE_SEQ(Word) -CONCRETE_SEQ(Word8) -CONCRETE_SEQ(Word16) -CONCRETE_SEQ(Word32) -CONCRETE_SEQ(Word64) -CONCRETE_SEQ(Float) -CONCRETE_SEQ(Double) -CONCRETE_SEQ(B.ByteString) -CONCRETE_SEQ(T.Text) -CONCRETE_SEQ(FPRoundingMode) -CONCRETE_SEQ_BV(WordN) -CONCRETE_SEQ_BV(IntN) -#endif - -instance (ValidFP eb sb) => SEq (FP eb sb) where - l .== r = con $ l == r - {-# INLINE (.==) #-} - --- List -deriving via (Default [a]) instance (SEq a) => SEq [a] - --- Maybe -deriving via (Default (Maybe a)) instance (SEq a) => SEq (Maybe a) - --- Either -deriving via (Default (Either e a)) instance (SEq e, SEq a) => SEq (Either e a) - --- ExceptT -instance (SEq (m (Either e a))) => SEq (ExceptT e m a) where - (ExceptT a) .== (ExceptT b) = a .== b - {-# INLINE (.==) #-} - --- MaybeT -instance (SEq (m (Maybe a))) => SEq (MaybeT m a) where - (MaybeT a) .== (MaybeT b) = a .== b - {-# INLINE (.==) #-} - --- () -instance SEq () where - _ .== _ = con True - {-# INLINE (.==) #-} - --- (,) -deriving via (Default (a, b)) instance (SEq a, SEq b) => SEq (a, b) - --- (,,) -deriving via (Default (a, b, c)) instance (SEq a, SEq b, SEq c) => SEq (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - (SEq a, SEq b, SEq c, SEq d) => - SEq (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - (SEq a, SEq b, SEq c, SEq d, SEq e) => - SEq (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f) => - SEq (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f, SEq g) => - SEq (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - (SEq a, SEq b, SEq c, SEq d, SEq e, SEq f, SEq g, SEq h) => - SEq (a, b, c, d, e, f, g, h) - --- Sum -deriving via - (Default (Sum f g a)) - instance - (SEq (f a), SEq (g a)) => SEq (Sum f g a) - --- Writer -instance (SEq (m (a, s))) => SEq (WriterLazy.WriterT s m a) where - (WriterLazy.WriterT l) .== (WriterLazy.WriterT r) = l .== r - {-# INLINE (.==) #-} - -instance (SEq (m (a, s))) => SEq (WriterStrict.WriterT s m a) where - (WriterStrict.WriterT l) .== (WriterStrict.WriterT r) = l .== r - {-# INLINE (.==) #-} - --- Identity -instance (SEq a) => SEq (Identity a) where - (Identity l) .== (Identity r) = l .== r - {-# INLINE (.==) #-} - --- IdentityT -instance (SEq (m a)) => SEq (IdentityT m a) where - (IdentityT l) .== (IdentityT r) = l .== r - {-# INLINE (.==) #-} - --- Symbolic types -#define SEQ_SIMPLE(symtype) \ -instance SEq symtype where \ - (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r; \ - {-# INLINE (.==) #-} - -#define SEQ_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SEq (symtype n) where \ - (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r; \ - {-# INLINE (.==) #-} - -#if 1 -SEQ_SIMPLE(SymBool) -SEQ_SIMPLE(SymInteger) -SEQ_SIMPLE(SymFPRoundingMode) -SEQ_BV(SymIntN) -SEQ_BV(SymWordN) -#endif - -instance (ValidFP eb sb) => SEq (SymFP eb sb) where - (SymFP l) .== (SymFP r) = SymBool $ pevalEqTerm l r - {-# INLINE (.==) #-} - --- Exceptions -deriving via (Default AssertionError) instance SEq AssertionError - -deriving via (Default VerificationConditions) instance SEq VerificationConditions - --- | Auxiliary class for 'SEq' instance derivation -class SEq' f where - -- | Auxiliary function for '(..==) derivation - (..==) :: f a -> f a -> SymBool - - infix 4 ..== - -instance SEq' U1 where - _ ..== _ = con True - {-# INLINE (..==) #-} - -instance SEq' V1 where - _ ..== _ = con True - {-# INLINE (..==) #-} - -instance (SEq c) => SEq' (K1 i c) where - (K1 a) ..== (K1 b) = a .== b - {-# INLINE (..==) #-} - -instance (SEq' a) => SEq' (M1 i c a) where - (M1 a) ..== (M1 b) = a ..== b - {-# INLINE (..==) #-} - -instance (SEq' a, SEq' b) => SEq' (a :+: b) where - (L1 a) ..== (L1 b) = a ..== b - (R1 a) ..== (R1 b) = a ..== b - _ ..== _ = con False - {-# INLINE (..==) #-} - -instance (SEq' a, SEq' b) => SEq' (a :*: b) where - (a1 :*: b1) ..== (a2 :*: b2) = (a1 ..== a2) .&& (b1 ..== b2) - {-# INLINE (..==) #-} - -instance (Generic a, SEq' (Rep a)) => SEq (Default a) where - Default l .== Default r = from l ..== from r - {-# INLINE (.==) #-} diff --git a/src/Grisette/Internal/Core/Data/Class/SOrd.hs b/src/Grisette/Internal/Core/Data/Class/SOrd.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core/Data/Class/SOrd.hs +++ /dev/null @@ -1,532 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Internal.Core.Data.Class.SOrd --- Copyright : (c) Sirui Lu 2021-2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.Data.Class.SOrd - ( -- * Symbolic total order relation - SOrd (..), - SOrd' (..), - symMax, - symMin, - mrgMax, - mrgMin, - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeLits (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default), - Generic (Rep, from), - K1 (K1), - M1 (M1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, liftToMonadUnion) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp, symIte) -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.PlainUnion - ( simpleMerge, - ) -import Grisette.Internal.Core.Data.Class.SEq (SEq ((./=), (.==)), SEq' ((..==))) -import Grisette.Internal.Core.Data.Class.SimpleMergeable - ( UnionMergeable1, - mrgIf, - ) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) -import Grisette.Internal.Core.Data.Class.TryMerge - ( mrgSingle, - tryMerge, - ) -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.SymPrim.Prim.Term - ( PEvalOrdTerm - ( pevalLeOrdTerm, - pevalLtOrdTerm - ), - pevalGeOrdTerm, - pevalGtOrdTerm, - ) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP (SymFP (SymFP), SymFPRoundingMode (SymFPRoundingMode)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim --- >>> :set -XDataKinds --- >>> :set -XBinaryLiterals --- >>> :set -XFlexibleContexts --- >>> :set -XFlexibleInstances --- >>> :set -XFunctionalDependencies - --- | Symbolic total order. Note that we can't use Haskell's 'Ord' class since --- symbolic comparison won't necessarily return a concrete 'Bool' or 'Ordering' --- value. --- --- >>> let a = 1 :: SymInteger --- >>> let b = 2 :: SymInteger --- >>> a .< b --- true --- >>> a .> b --- false --- --- >>> let a = "a" :: SymInteger --- >>> let b = "b" :: SymInteger --- >>> a .< b --- (< a b) --- >>> a .<= b --- (<= a b) --- >>> a .> b --- (< b a) --- >>> a .>= b --- (<= b a) --- --- For `symCompare`, `Ordering` is not a solvable type, and the result would --- be wrapped in a union-like monad. See `Grisette.Core.Control.Monad.UnionMBase` and `PlainUnion` for more --- information. --- --- >>> a `symCompare` b :: UnionM Ordering -- UnionM is UnionMBase specialized with SymBool --- {If (< a b) LT (If (= a b) EQ GT)} --- --- __Note:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving SOrd via (Default X) -class (SEq a) => SOrd a where - (.<) :: a -> a -> SymBool - infix 4 .< - (.<=) :: a -> a -> SymBool - infix 4 .<= - (.>) :: a -> a -> SymBool - infix 4 .> - (.>=) :: a -> a -> SymBool - infix 4 .>= - x .< y = x .<= y .&& x ./= y - x .> y = y .< x - x .>= y = y .<= x - symCompare :: a -> a -> UnionM Ordering - symCompare l r = - mrgIf - (l .< r) - (mrgSingle LT) - (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) - {-# MINIMAL (.<=) #-} - -instance (SEq a, Generic a, SOrd' (Rep a)) => SOrd (Default a) where - (Default l) .<= (Default r) = l `derivedSymLe` r - (Default l) .< (Default r) = l `derivedSymLt` r - (Default l) .>= (Default r) = l `derivedSymGe` r - (Default l) .> (Default r) = l `derivedSymGt` r - symCompare (Default l) (Default r) = derivedSymCompare l r - -#define CONCRETE_SORD(type) \ -instance SOrd type where \ - l .<= r = con $ l <= r; \ - l .< r = con $ l < r; \ - l .>= r = con $ l >= r; \ - l .> r = con $ l > r; \ - symCompare l r = mrgSingle $ compare l r - -#define CONCRETE_SORD_BV(type) \ -instance (KnownNat n, 1 <= n) => SOrd (type n) where \ - l .<= r = con $ l <= r; \ - l .< r = con $ l < r; \ - l .>= r = con $ l >= r; \ - l .> r = con $ l > r; \ - symCompare l r = mrgSingle $ compare l r - -#if 1 -CONCRETE_SORD(Bool) -CONCRETE_SORD(Integer) -CONCRETE_SORD(Char) -CONCRETE_SORD(Int) -CONCRETE_SORD(Int8) -CONCRETE_SORD(Int16) -CONCRETE_SORD(Int32) -CONCRETE_SORD(Int64) -CONCRETE_SORD(Word) -CONCRETE_SORD(Word8) -CONCRETE_SORD(Word16) -CONCRETE_SORD(Word32) -CONCRETE_SORD(Word64) -CONCRETE_SORD(B.ByteString) -CONCRETE_SORD(T.Text) -CONCRETE_SORD(FPRoundingMode) -CONCRETE_SORD_BV(WordN) -CONCRETE_SORD_BV(IntN) -#endif - -instance (ValidFP eb sb) => SOrd (FP eb sb) where - l .<= r = con $ l <= r - l .< r = con $ l < r - l .>= r = con $ l >= r - l .> r = con $ l > r - -symCompareSingleList :: (SOrd a) => Bool -> Bool -> [a] -> [a] -> SymBool -symCompareSingleList isLess isStrict = go - where - go [] [] = con (not isStrict) - go (x : xs) (y : ys) = (if isLess then x .< y else x .> y) .|| (x .== y .&& go xs ys) - go [] _ = if isLess then con True else con False - go _ [] = if isLess then con False else con True - -symCompareList :: (SOrd a) => [a] -> [a] -> UnionM Ordering -symCompareList [] [] = mrgSingle EQ -symCompareList (x : xs) (y : ys) = do - oxy <- symCompare x y - case oxy of - LT -> mrgSingle LT - EQ -> symCompareList xs ys - GT -> mrgSingle GT -symCompareList [] _ = mrgSingle LT -symCompareList _ [] = mrgSingle GT - -instance (SOrd a) => SOrd [a] where - (.<=) = symCompareSingleList True False - (.<) = symCompareSingleList True True - (.>=) = symCompareSingleList False False - (.>) = symCompareSingleList False True - symCompare = symCompareList - -deriving via (Default (Maybe a)) instance (SOrd a) => SOrd (Maybe a) - -deriving via (Default (Either a b)) instance (SOrd a, SOrd b) => SOrd (Either a b) - -deriving via (Default ()) instance SOrd () - -deriving via (Default (a, b)) instance (SOrd a, SOrd b) => SOrd (a, b) - -deriving via (Default (a, b, c)) instance (SOrd a, SOrd b, SOrd c) => SOrd (a, b, c) - -deriving via - (Default (a, b, c, d)) - instance - (SOrd a, SOrd b, SOrd c, SOrd d) => - SOrd (a, b, c, d) - -deriving via - (Default (a, b, c, d, e)) - instance - (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e) => - SOrd (a, b, c, d, e) - -deriving via - (Default (a, b, c, d, e, f)) - instance - (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e, SOrd f) => - SOrd (a, b, c, d, e, f) - -deriving via - (Default (a, b, c, d, e, f, g)) - instance - (SOrd a, SOrd b, SOrd c, SOrd d, SOrd e, SOrd f, SOrd g) => - SOrd (a, b, c, d, e, f, g) - -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( SOrd a, - SOrd b, - SOrd c, - SOrd d, - SOrd e, - SOrd f, - SOrd g, - SOrd h - ) => - SOrd (a, b, c, d, e, f, g, h) - -deriving via - (Default (Sum f g a)) - instance - (SOrd (f a), SOrd (g a)) => SOrd (Sum f g a) - -instance (SOrd (m (Maybe a))) => SOrd (MaybeT m a) where - (MaybeT l) .<= (MaybeT r) = l .<= r - (MaybeT l) .< (MaybeT r) = l .< r - (MaybeT l) .>= (MaybeT r) = l .>= r - (MaybeT l) .> (MaybeT r) = l .> r - symCompare (MaybeT l) (MaybeT r) = symCompare l r - -instance (SOrd (m (Either e a))) => SOrd (ExceptT e m a) where - (ExceptT l) .<= (ExceptT r) = l .<= r - (ExceptT l) .< (ExceptT r) = l .< r - (ExceptT l) .>= (ExceptT r) = l .>= r - (ExceptT l) .> (ExceptT r) = l .> r - symCompare (ExceptT l) (ExceptT r) = symCompare l r - -instance (SOrd (m (a, s))) => SOrd (WriterLazy.WriterT s m a) where - (WriterLazy.WriterT l) .<= (WriterLazy.WriterT r) = l .<= r - (WriterLazy.WriterT l) .< (WriterLazy.WriterT r) = l .< r - (WriterLazy.WriterT l) .>= (WriterLazy.WriterT r) = l .>= r - (WriterLazy.WriterT l) .> (WriterLazy.WriterT r) = l .> r - symCompare (WriterLazy.WriterT l) (WriterLazy.WriterT r) = symCompare l r - -instance (SOrd (m (a, s))) => SOrd (WriterStrict.WriterT s m a) where - (WriterStrict.WriterT l) .<= (WriterStrict.WriterT r) = l .<= r - (WriterStrict.WriterT l) .< (WriterStrict.WriterT r) = l .< r - (WriterStrict.WriterT l) .>= (WriterStrict.WriterT r) = l .>= r - (WriterStrict.WriterT l) .> (WriterStrict.WriterT r) = l .> r - symCompare (WriterStrict.WriterT l) (WriterStrict.WriterT r) = symCompare l r - -instance (SOrd a) => SOrd (Identity a) where - (Identity l) .<= (Identity r) = l .<= r - (Identity l) .< (Identity r) = l .< r - (Identity l) .>= (Identity r) = l .>= r - (Identity l) .> (Identity r) = l .> r - (Identity l) `symCompare` (Identity r) = l `symCompare` r - -instance (SOrd (m a)) => SOrd (IdentityT m a) where - (IdentityT l) .<= (IdentityT r) = l .<= r - (IdentityT l) .< (IdentityT r) = l .< r - (IdentityT l) .>= (IdentityT r) = l .>= r - (IdentityT l) .> (IdentityT r) = l .> r - (IdentityT l) `symCompare` (IdentityT r) = l `symCompare` r - --- SOrd -#define SORD_SIMPLE(symtype) \ -instance SOrd symtype where \ - (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ - (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ - (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ - (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ - a `symCompare` b = mrgIf \ - (a .< b) \ - (mrgSingle LT) \ - (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)) - -#define SORD_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SOrd (symtype n) where \ - (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ - (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ - (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ - (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ - a `symCompare` b = mrgIf \ - (a .< b) \ - (mrgSingle LT) \ - (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)) - -instance (ValidFP eb sb) => SOrd (SymFP eb sb) where - (SymFP a) .<= (SymFP b) = SymBool $ pevalLeOrdTerm a b - (SymFP a) .< (SymFP b) = SymBool $ pevalLtOrdTerm a b - (SymFP a) .>= (SymFP b) = SymBool $ pevalGeOrdTerm a b - (SymFP a) .> (SymFP b) = SymBool $ pevalGtOrdTerm a b - -instance SOrd SymBool where - l .<= r = symNot l .|| r - l .< r = symNot l .&& r - l .>= r = l .|| symNot r - l .> r = l .&& symNot r - symCompare l r = - mrgIf - (symNot l .&& r) - (mrgSingle LT) - (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) - -#if 1 -SORD_SIMPLE(SymInteger) -SORD_SIMPLE(SymFPRoundingMode) -SORD_BV(SymIntN) -SORD_BV(SymWordN) -#endif - --- Exception -instance SOrd AssertionError where - _ .<= _ = con True - _ .< _ = con False - _ .>= _ = con True - _ .> _ = con False - _ `symCompare` _ = mrgSingle EQ - -instance SOrd VerificationConditions where - l .>= r = con $ l >= r - l .> r = con $ l > r - l .<= r = con $ l <= r - l .< r = con $ l < r - l `symCompare` r = mrgSingle $ l `compare` r - --- UnionM -instance (SOrd a, Mergeable a) => SOrd (UnionM a) where - x .<= y = simpleMerge $ do - x1 <- tryMerge x - y1 <- tryMerge y - mrgSingle $ x1 .<= y1 - x .< y = simpleMerge $ do - x1 <- tryMerge x - y1 <- tryMerge y - mrgSingle $ x1 .< y1 - x .>= y = simpleMerge $ do - x1 <- tryMerge x - y1 <- tryMerge y - mrgSingle $ x1 .>= y1 - x .> y = simpleMerge $ do - x1 <- tryMerge x - y1 <- tryMerge y - mrgSingle $ x1 .> y1 - x `symCompare` y = liftToMonadUnion $ do - x1 <- tryMerge x - y1 <- tryMerge y - x1 `symCompare` y1 - --- | Auxiliary class for 'SOrd' instance derivation -class (SEq' f) => SOrd' f where - -- | Auxiliary function for '(..<) derivation - (..<) :: f a -> f a -> SymBool - - infix 4 ..< - - -- | Auxiliary function for '(..<=) derivation - (..<=) :: f a -> f a -> SymBool - - infix 4 ..<= - - -- | Auxiliary function for '(..>) derivation - (..>) :: f a -> f a -> SymBool - - infix 4 ..> - - -- | Auxiliary function for '(..>=) derivation - (..>=) :: f a -> f a -> SymBool - - infix 4 ..>= - - -- | Auxiliary function for 'symCompare' derivation - symCompare' :: f a -> f a -> UnionM Ordering - -instance SOrd' U1 where - _ ..< _ = con False - _ ..<= _ = con True - _ ..> _ = con False - _ ..>= _ = con True - symCompare' _ _ = mrgSingle EQ - -instance SOrd' V1 where - _ ..< _ = con False - _ ..<= _ = con True - _ ..> _ = con False - _ ..>= _ = con True - symCompare' _ _ = mrgSingle EQ - -instance (SOrd c) => SOrd' (K1 i c) where - (K1 a) ..< (K1 b) = a .< b - (K1 a) ..<= (K1 b) = a .<= b - (K1 a) ..> (K1 b) = a .> b - (K1 a) ..>= (K1 b) = a .>= b - symCompare' (K1 a) (K1 b) = symCompare a b - -instance (SOrd' a) => SOrd' (M1 i c a) where - (M1 a) ..< (M1 b) = a ..< b - (M1 a) ..<= (M1 b) = a ..<= b - (M1 a) ..> (M1 b) = a ..> b - (M1 a) ..>= (M1 b) = a ..>= b - symCompare' (M1 a) (M1 b) = symCompare' a b - -instance (SOrd' a, SOrd' b) => SOrd' (a :+: b) where - (L1 _) ..< (R1 _) = con True - (L1 a) ..< (L1 b) = a ..< b - (R1 _) ..< (L1 _) = con False - (R1 a) ..< (R1 b) = a ..< b - (L1 _) ..<= (R1 _) = con True - (L1 a) ..<= (L1 b) = a ..<= b - (R1 _) ..<= (L1 _) = con False - (R1 a) ..<= (R1 b) = a ..<= b - - (L1 _) ..> (R1 _) = con False - (L1 a) ..> (L1 b) = a ..> b - (R1 _) ..> (L1 _) = con True - (R1 a) ..> (R1 b) = a ..> b - (L1 _) ..>= (R1 _) = con False - (L1 a) ..>= (L1 b) = a ..>= b - (R1 _) ..>= (L1 _) = con True - (R1 a) ..>= (R1 b) = a ..>= b - - symCompare' (L1 a) (L1 b) = symCompare' a b - symCompare' (L1 _) (R1 _) = mrgSingle LT - symCompare' (R1 a) (R1 b) = symCompare' a b - symCompare' (R1 _) (L1 _) = mrgSingle GT - -instance (SOrd' a, SOrd' b) => SOrd' (a :*: b) where - (a1 :*: b1) ..< (a2 :*: b2) = (a1 ..< a2) .|| ((a1 ..== a2) .&& (b1 ..< b2)) - (a1 :*: b1) ..<= (a2 :*: b2) = (a1 ..< a2) .|| ((a1 ..== a2) .&& (b1 ..<= b2)) - (a1 :*: b1) ..> (a2 :*: b2) = (a1 ..> a2) .|| ((a1 ..== a2) .&& (b1 ..> b2)) - (a1 :*: b1) ..>= (a2 :*: b2) = (a1 ..> a2) .|| ((a1 ..== a2) .&& (b1 ..>= b2)) - symCompare' (a1 :*: b1) (a2 :*: b2) = do - l <- symCompare' a1 a2 - case l of - EQ -> symCompare' b1 b2 - _ -> mrgSingle l - -derivedSymLt :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool -derivedSymLt x y = from x ..< from y - -derivedSymLe :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool -derivedSymLe x y = from x ..<= from y - -derivedSymGt :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool -derivedSymGt x y = from x ..> from y - -derivedSymGe :: (Generic a, SOrd' (Rep a)) => a -> a -> SymBool -derivedSymGe x y = from x ..>= from y - -derivedSymCompare :: (Generic a, SOrd' (Rep a)) => a -> a -> UnionM Ordering -derivedSymCompare x y = symCompare' (from x) (from y) - -symMax :: (SOrd a, ITEOp a) => a -> a -> a -symMax x y = symIte (x .>= y) x y - -symMin :: (SOrd a, ITEOp a) => a -> a -> a -symMin x y = symIte (x .>= y) y x - -mrgMax :: - (SOrd a, Mergeable a, UnionMergeable1 m, Applicative m) => - a -> - a -> - m a -mrgMax x y = mrgIf (x .>= y) (pure x) (pure y) - -mrgMin :: - (SOrd a, Mergeable a, UnionMergeable1 m, Applicative m) => - a -> - a -> - m a -mrgMin x y = mrgIf (x .>= y) (pure y) (pure x) diff --git a/src/Grisette/Internal/Core/Data/Class/SafeDivision.hs b/src/Grisette/Internal/Core/Data/Class/SafeDivision.hs --- a/src/Grisette/Internal/Core/Data/Class/SafeDivision.hs +++ b/src/Grisette/Internal/Core/Data/Class/SafeDivision.hs @@ -30,17 +30,18 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.SEq (SEq ((.==))) import Grisette.Internal.Core.Data.Class.SimpleMergeable ( mrgIf, ) import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((.==))) import Grisette.Internal.Core.Data.Class.TryMerge ( TryMerge, mrgSingle, + tryMerge, ) import Grisette.Internal.SymPrim.BV ( IntN, @@ -59,14 +60,13 @@ SymWordN (SymWordN), ) import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Lib.Control.Monad (mrgReturn) -import Grisette.Lib.Control.Monad.Except (mrgThrowError) import Grisette.Lib.Data.Functor (mrgFmap) -- $setup -- >>> import Grisette.Core -- >>> import Grisette.SymPrim -- >>> import Control.Monad.Except +-- >>> import Control.Exception -- | Safe division with monadic error handling in multi-path -- execution. These procedures throw an exception when the @@ -75,7 +75,7 @@ class (MonadError e m, TryMerge m, Mergeable a) => SafeDivision e a m where -- | Safe signed 'div' with monadic error handling in multi-path execution. -- - -- >>> safeDiv (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger + -- >>> safeDiv (ssym "a") (ssym "b") :: ExceptT ArithException Union SymInteger -- ExceptT {If (= b 0) (Left divide by zero) (Right (div a b))} safeDiv :: a -> a -> m a safeDiv l r = mrgFmap fst $ safeDivMod l r @@ -83,7 +83,7 @@ -- | Safe signed 'mod' with monadic error handling in multi-path execution. -- - -- >>> safeMod (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger + -- >>> safeMod (ssym "a") (ssym "b") :: ExceptT ArithException Union SymInteger -- ExceptT {If (= b 0) (Left divide by zero) (Right (mod a b))} safeMod :: a -> a -> m a safeMod l r = mrgFmap snd $ safeDivMod l r @@ -91,13 +91,13 @@ -- | Safe signed 'divMod' with monadic error handling in multi-path execution. -- - -- >>> safeDivMod (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymInteger, SymInteger) + -- >>> safeDivMod (ssym "a") (ssym "b") :: ExceptT ArithException Union (SymInteger, SymInteger) -- ExceptT {If (= b 0) (Left divide by zero) (Right ((div a b),(mod a b)))} safeDivMod :: a -> a -> m (a, a) safeDivMod l r = do d <- safeDiv l r m <- safeMod l r - mrgReturn (d, m) + mrgSingle (d, m) {-# INLINE safeDivMod #-} -- | Safe signed 'quot' with monadic error handling in multi-path execution. @@ -115,7 +115,7 @@ safeQuotRem l r = do q <- safeQuot l r m <- safeRem l r - mrgReturn (q, m) + mrgSingle (q, m) {-# INLINE safeQuotRem #-} {-# MINIMAL @@ -130,8 +130,8 @@ a -> m r concreteSafeDivisionHelper f l r - | r == 0 = mrgThrowError DivideByZero - | otherwise = mrgReturn $ f l r + | r == 0 = tryMerge $ throwError DivideByZero + | otherwise = mrgSingle $ f l r concreteSignedBoundedSafeDivisionHelper :: ( MonadError ArithException m, @@ -145,9 +145,9 @@ a -> m r concreteSignedBoundedSafeDivisionHelper f l r - | r == 0 = mrgThrowError DivideByZero - | l == minBound && r == -1 = mrgThrowError Overflow - | otherwise = mrgReturn $ f l r + | r == 0 = tryMerge $ throwError DivideByZero + | l == minBound && r == -1 = tryMerge $ throwError Overflow + | otherwise = mrgSingle $ f l r #define QUOTE() ' #define QID(a) a diff --git a/src/Grisette/Internal/Core/Data/Class/SafeLinearArith.hs b/src/Grisette/Internal/Core/Data/Class/SafeLinearArith.hs --- a/src/Grisette/Internal/Core/Data/Class/SafeLinearArith.hs +++ b/src/Grisette/Internal/Core/Data/Class/SafeLinearArith.hs @@ -29,20 +29,21 @@ import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) import Grisette.Internal.Core.Data.Class.LogicalOp ( LogicalOp ((.&&), (.||)), ) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.SEq (SEq ((./=), (.==))) -import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<), (.>), (.>=))) import Grisette.Internal.Core.Data.Class.SimpleMergeable ( mrgIf, ) import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((./=), (.==))) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd ((.<), (.>), (.>=))) import Grisette.Internal.Core.Data.Class.TryMerge ( TryMerge, mrgSingle, + tryMerge, ) import Grisette.Internal.SymPrim.BV ( IntN, @@ -53,13 +54,12 @@ SymWordN, ) import Grisette.Internal.SymPrim.SymInteger (SymInteger) -import Grisette.Lib.Control.Monad (mrgReturn) -import Grisette.Lib.Control.Monad.Except (mrgThrowError) -- $setup -- >>> import Grisette.Core -- >>> import Grisette.SymPrim -- >>> import Control.Monad.Except +-- >>> import Control.Exception -- | Safe division with monadic error handling in multi-path -- execution. These procedures throw an exception when overflow or underflow happens. @@ -68,27 +68,27 @@ -- | Safe '+' with monadic error handling in multi-path execution. -- Overflows or underflows are treated as errors. -- - -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger + -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException Union SymInteger -- ExceptT {Right (+ a b)} - -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymIntN 4) + -- >>> safeAdd (ssym "a") (ssym "b") :: ExceptT ArithException Union (SymIntN 4) -- ExceptT {If (ite (< 0x0 a) (&& (< 0x0 b) (< (+ a b) 0x0)) (&& (< a 0x0) (&& (< b 0x0) (<= 0x0 (+ a b))))) (If (< 0x0 a) (Left arithmetic overflow) (Left arithmetic underflow)) (Right (+ a b))} safeAdd :: a -> a -> m a -- | Safe 'negate' with monadic error handling in multi-path execution. -- Overflows or underflows are treated as errors. -- - -- >>> safeNeg (ssym "a") :: ExceptT ArithException UnionM SymInteger + -- >>> safeNeg (ssym "a") :: ExceptT ArithException Union SymInteger -- ExceptT {Right (- a)} - -- >>> safeNeg (ssym "a") :: ExceptT ArithException UnionM (SymIntN 4) + -- >>> safeNeg (ssym "a") :: ExceptT ArithException Union (SymIntN 4) -- ExceptT {If (= a 0x8) (Left arithmetic overflow) (Right (- a))} safeNeg :: a -> m a -- | Safe '-' with monadic error handling in multi-path execution. -- Overflows or underflows are treated as errors. -- - -- >>> safeSub (ssym "a") (ssym "b") :: ExceptT ArithException UnionM SymInteger + -- >>> safeSub (ssym "a") (ssym "b") :: ExceptT ArithException Union SymInteger -- ExceptT {Right (+ a (- b))} - -- >>> safeSub (ssym "a") (ssym "b") :: ExceptT ArithException UnionM (SymIntN 4) + -- >>> safeSub (ssym "a") (ssym "b") :: ExceptT ArithException Union (SymIntN 4) -- ExceptT {If (ite (<= 0x0 a) (&& (< b 0x0) (< (+ a (- b)) 0x0)) (&& (< a 0x0) (&& (< 0x0 b) (< 0x0 (+ a (- b)))))) (If (<= 0x0 a) (Left arithmetic overflow) (Left arithmetic underflow)) (Right (+ a (- b)))} safeSub :: a -> a -> m a @@ -103,17 +103,20 @@ #define SAFE_LINARITH_SIGNED_CONCRETE_BODY \ safeAdd l r = let res = l + r in \ if l > 0 && r > 0 && res < 0 \ - then mrgThrowError Overflow \ + then tryMerge $ throwError Overflow \ else if l < 0 && r < 0 && res >= 0 \ - then mrgThrowError Underflow \ - else mrgReturn res;\ + then tryMerge $ throwError Underflow \ + else mrgSingle res;\ safeSub l r = let res = l - r in \ if l >= 0 && r < 0 && res < 0 \ - then mrgThrowError Overflow \ + then tryMerge $ throwError Overflow \ else if l < 0 && r > 0 && res > 0 \ - then mrgThrowError Underflow \ - else mrgReturn res;\ - safeNeg v = if v == minBound then mrgThrowError Overflow else mrgReturn $ -v + then tryMerge $ throwError Underflow \ + else mrgSingle res;\ + safeNeg v = \ + if v == minBound \ + then tryMerge $ throwError Overflow \ + else mrgSingle $ -v #define SAFE_LINARITH_SIGNED_CONCRETE(type) \ instance \ @@ -132,13 +135,13 @@ #define SAFE_LINARITH_UNSIGNED_CONCRETE_BODY \ safeAdd l r = let res = l + r in \ if l > res || r > res \ - then mrgThrowError Overflow \ - else mrgReturn res;\ + then tryMerge $ throwError Overflow \ + else mrgSingle res;\ safeSub l r = \ if r > l \ - then mrgThrowError Underflow \ - else mrgReturn $ l - r;\ - safeNeg v = if v /= 0 then mrgThrowError Underflow else mrgReturn $ -v + then tryMerge $ throwError Underflow \ + else mrgSingle $ l - r;\ + safeNeg v = if v /= 0 then tryMerge $ throwError Underflow else mrgSingle $ -v #define SAFE_LINARITH_UNSIGNED_CONCRETE(type) \ instance \ diff --git a/src/Grisette/Internal/Core/Data/Class/SafeSymRotate.hs b/src/Grisette/Internal/Core/Data/Class/SafeSymRotate.hs --- a/src/Grisette/Internal/Core/Data/Class/SafeSymRotate.hs +++ b/src/Grisette/Internal/Core/Data/Class/SafeSymRotate.hs @@ -19,16 +19,20 @@ module Grisette.Internal.Core.Data.Class.SafeSymRotate (SafeSymRotate (..)) where import Control.Exception (ArithException (Overflow)) -import Control.Monad.Error.Class (MonadError) +import Control.Monad.Error.Class (MonadError (throwError)) import Data.Bits (Bits (rotateL, rotateR), FiniteBits (finiteBitSize)) import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<))) import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf) -import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd ((.<))) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingle, + tryMerge, + ) import Grisette.Internal.SymPrim.BV (IntN, WordN) import Grisette.Internal.SymPrim.Prim.Term ( PEvalRotateTerm @@ -40,8 +44,6 @@ ( SymIntN (SymIntN), SymWordN (SymWordN), ) -import Grisette.Lib.Control.Monad (mrgReturn) -import Grisette.Lib.Control.Monad.Except (mrgThrowError) -- | Safe rotation operations. The operators will reject negative shift amounts. class (MonadError e m, TryMerge m, Mergeable a) => SafeSymRotate e a m where @@ -60,9 +62,9 @@ a -> a -> m a -safeSymRotateLConcreteNum _ s | s < 0 = mrgThrowError Overflow +safeSymRotateLConcreteNum _ s | s < 0 = tryMerge $ throwError Overflow safeSymRotateLConcreteNum a s = - mrgReturn $ rotateL a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s)) + mrgSingle $ rotateL a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s)) -- | This function handles the case when the shift amount is out the range of -- `Int` correctly. @@ -76,9 +78,9 @@ a -> a -> m a -safeSymRotateRConcreteNum _ s | s < 0 = mrgThrowError Overflow +safeSymRotateRConcreteNum _ s | s < 0 = tryMerge $ throwError Overflow safeSymRotateRConcreteNum a s = - mrgReturn $ rotateR a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s)) + mrgSingle $ rotateR a (fromIntegral $ s `rem` fromIntegral (finiteBitSize s)) #define SAFE_SYM_ROTATE_CONCRETE(T) \ instance (MonadError ArithException m, TryMerge m) => \ @@ -118,9 +120,9 @@ SafeSymRotate ArithException (SymWordN n) m where safeSymRotateL (SymWordN ta) (SymWordN tr) = - mrgReturn $ SymWordN $ pevalRotateLeftTerm ta tr + mrgSingle $ SymWordN $ pevalRotateLeftTerm ta tr safeSymRotateR (SymWordN ta) (SymWordN tr) = - mrgReturn $ SymWordN $ pevalRotateRightTerm ta tr + mrgSingle $ SymWordN $ pevalRotateRightTerm ta tr instance (MonadError ArithException m, MonadUnion m, KnownNat n, 1 <= n) => @@ -129,10 +131,10 @@ safeSymRotateL (SymIntN ta) r@(SymIntN tr) = mrgIf (r .< 0) - (mrgThrowError Overflow) - (mrgReturn $ SymIntN $ pevalRotateLeftTerm ta tr) + (throwError Overflow) + (mrgSingle $ SymIntN $ pevalRotateLeftTerm ta tr) safeSymRotateR (SymIntN ta) r@(SymIntN tr) = mrgIf (r .< 0) - (mrgThrowError Overflow) - (mrgReturn $ SymIntN $ pevalRotateRightTerm ta tr) + (throwError Overflow) + (mrgSingle $ SymIntN $ pevalRotateRightTerm ta tr) diff --git a/src/Grisette/Internal/Core/Data/Class/SafeSymShift.hs b/src/Grisette/Internal/Core/Data/Class/SafeSymShift.hs --- a/src/Grisette/Internal/Core/Data/Class/SafeSymShift.hs +++ b/src/Grisette/Internal/Core/Data/Class/SafeSymShift.hs @@ -11,29 +11,41 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Grisette.Internal.Core.Data.Class.SafeSymShift +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Internal.Core.Data.Class.SafeSymShift ( SafeSymShift (..), ) where import Control.Exception (ArithException (Overflow)) -import Control.Monad.Error.Class (MonadError) +import Control.Monad.Error.Class (MonadError (throwError)) import Data.Bits (Bits (shiftL, shiftR), FiniteBits (finiteBitSize)) import Data.Int (Int16, Int32, Int64, Int8) import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeLits (KnownNat, type (<=)) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) import Grisette.Internal.Core.Data.Class.LogicalOp ( LogicalOp ((.&&), (.||)), ) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.SOrd - ( SOrd ((.<), (.>=)), - ) import Grisette.Internal.Core.Data.Class.SimpleMergeable ( mrgIf, ) -import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Internal.Core.Data.Class.SymOrd + ( SymOrd ((.<), (.>=)), + ) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingle, + tryMerge, + ) import Grisette.Internal.SymPrim.BV (IntN, WordN) import Grisette.Internal.SymPrim.Prim.Term ( PEvalShiftTerm @@ -42,8 +54,6 @@ ), ) import Grisette.Internal.SymPrim.SymBV (SymIntN (SymIntN), SymWordN (SymWordN)) -import Grisette.Lib.Control.Monad (mrgReturn) -import Grisette.Lib.Control.Monad.Except (mrgThrowError) -- | Safe version for `shiftL` or `shiftR`. -- @@ -76,11 +86,13 @@ a -> a -> m a -safeSymShiftLConcreteNum _ _ s | s < 0 = mrgThrowError Overflow +safeSymShiftLConcreteNum _ _ s | s < 0 = tryMerge $ throwError Overflow safeSymShiftLConcreteNum allowLargeShiftAmount a s | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) = - if allowLargeShiftAmount then mrgReturn 0 else mrgThrowError Overflow -safeSymShiftLConcreteNum _ a s = mrgReturn $ shiftL a (fromIntegral s) + if allowLargeShiftAmount + then mrgSingle 0 + else tryMerge $ throwError Overflow +safeSymShiftLConcreteNum _ a s = mrgSingle $ shiftL a (fromIntegral s) -- | This function handles the case when the shift amount is out the range of -- `Int` correctly. @@ -95,11 +107,13 @@ a -> a -> m a -safeSymShiftRConcreteNum _ _ s | s < 0 = mrgThrowError Overflow +safeSymShiftRConcreteNum _ _ s | s < 0 = tryMerge $ throwError Overflow safeSymShiftRConcreteNum allowLargeShiftAmount a s | (fromIntegral s :: Integer) >= fromIntegral (finiteBitSize a) = - if allowLargeShiftAmount then mrgReturn 0 else mrgThrowError Overflow -safeSymShiftRConcreteNum _ a s = mrgReturn $ shiftR a (fromIntegral s) + if allowLargeShiftAmount + then mrgSingle 0 + else tryMerge $ throwError Overflow +safeSymShiftRConcreteNum _ a s = mrgSingle $ shiftR a (fromIntegral s) #define SAFE_SYM_SHIFT_CONCRETE(T) \ instance (MonadError ArithException m, TryMerge m) => \ @@ -151,12 +165,12 @@ safeSymStrictShiftL a@(SymWordN ta) s@(SymWordN ts) = mrgIf (s .>= fromIntegral (finiteBitSize a)) - (mrgThrowError Overflow) + (throwError Overflow) (return $ SymWordN $ pevalShiftLeftTerm ta ts) safeSymStrictShiftR a@(SymWordN ta) s@(SymWordN ts) = mrgIf (s .>= fromIntegral (finiteBitSize a)) - (mrgThrowError Overflow) + (throwError Overflow) (return $ SymWordN $ pevalShiftRightTerm ta ts) instance @@ -166,24 +180,24 @@ safeSymShiftL (SymIntN a) ss@(SymIntN s) = mrgIf (ss .< 0) - (mrgThrowError Overflow) + (throwError Overflow) (return $ SymIntN $ pevalShiftLeftTerm a s) safeSymShiftR (SymIntN a) ss@(SymIntN s) = mrgIf (ss .< 0) - (mrgThrowError Overflow) + (throwError Overflow) (return $ SymIntN $ pevalShiftRightTerm a s) safeSymStrictShiftL a@(SymIntN ta) s@(SymIntN ts) = mrgIf (s .< 0 .|| (bs .>= 0 .&& s .>= bs)) - (mrgThrowError Overflow) + (throwError Overflow) (return $ SymIntN $ pevalShiftLeftTerm ta ts) where bs = fromIntegral (finiteBitSize a) safeSymStrictShiftR a@(SymIntN ta) s@(SymIntN ts) = mrgIf (s .< 0 .|| (bs .>= 0 .&& s .>= bs)) - (mrgThrowError Overflow) + (throwError Overflow) (return $ SymIntN $ pevalShiftRightTerm ta ts) where bs = fromIntegral (finiteBitSize a) diff --git a/src/Grisette/Internal/Core/Data/Class/SignConversion.hs b/src/Grisette/Internal/Core/Data/Class/SignConversion.hs --- a/src/Grisette/Internal/Core/Data/Class/SignConversion.hs +++ b/src/Grisette/Internal/Core/Data/Class/SignConversion.hs @@ -1,5 +1,13 @@ {-# LANGUAGE FunctionalDependencies #-} +-- | +-- Module : Grisette.Internal.Core.Data.Class.SignConversion +-- Copyright : (c) Sirui Lu 2023-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Internal.Core.Data.Class.SignConversion ( SignConversion (..), ) diff --git a/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs b/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs --- a/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs +++ b/src/Grisette/Internal/Core/Data/Class/SimpleMergeable.hs @@ -4,12 +4,14 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -28,7 +30,15 @@ mrgIte1, SimpleMergeable2 (..), mrgIte2, - UnionMergeable1 (..), + + -- * Generic 'SimpleMergeable' + SimpleMergeableArgs (..), + GSimpleMergeable (..), + genericMrgIte, + genericLiftMrgIte, + + -- * Symbolic branching + SymBranching (..), mrgIf, mergeWithStrategy, merge, @@ -49,22 +59,32 @@ import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) import qualified Control.Monad.Writer.Lazy as WriterLazy import qualified Control.Monad.Writer.Strict as WriterStrict +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) import Data.Kind (Type) +import Data.Monoid (Alt, Ap, Endo (Endo)) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) import GHC.Generics ( Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), K1 (K1), M1 (M1), + Par1 (Par1), + Rec1 (Rec1), U1, V1, + (:.:) (Comp1), type (:*:) ((:*:)), ) import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving (Default (Default)) +import Generics.Deriving (Default (Default), Default1 (Default1)) import Grisette.Internal.Core.Control.Exception (AssertionError) import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) import Grisette.Internal.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable', + ( GMergeable, + Mergeable (rootStrategy), Mergeable1 (liftRootStrategy), Mergeable2 (liftRootStrategy2), Mergeable3 (liftRootStrategy3), @@ -89,36 +109,17 @@ import Grisette.Internal.SymPrim.SymInteger (SymInteger) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) -- $setup -- >>> import Grisette.Core -- >>> import Grisette.SymPrim -- >>> import Control.Monad.Identity --- | Auxiliary class for the generic derivation for the 'SimpleMergeable' class. -class SimpleMergeable' f where - mrgIte' :: SymBool -> f a -> f a -> f a - -instance (SimpleMergeable' U1) where - mrgIte' _ t _ = t - {-# INLINE mrgIte' #-} - -instance (SimpleMergeable' V1) where - mrgIte' _ t _ = t - {-# INLINE mrgIte' #-} - -instance (SimpleMergeable c) => (SimpleMergeable' (K1 i c)) where - mrgIte' cond (K1 a) (K1 b) = K1 $ mrgIte cond a b - {-# INLINE mrgIte' #-} - -instance (SimpleMergeable' a) => (SimpleMergeable' (M1 i c a)) where - mrgIte' cond (M1 a) (M1 b) = M1 $ mrgIte' cond a b - {-# INLINE mrgIte' #-} - -instance (SimpleMergeable' a, SimpleMergeable' b) => (SimpleMergeable' (a :*: b)) where - mrgIte' cond (a1 :*: a2) (b1 :*: b2) = mrgIte' cond a1 b1 :*: mrgIte' cond a2 b2 - {-# INLINE mrgIte' #-} - -- | This class indicates that a type has a simple root merge strategy. -- -- __Note:__ This type class can be derived for algebraic data types. @@ -134,12 +135,11 @@ -- (ite a b c) mrgIte :: SymBool -> a -> a -> a -instance (Generic a, Mergeable' (Rep a), SimpleMergeable' (Rep a)) => SimpleMergeable (Default a) where - mrgIte cond (Default a) (Default b) = Default $ to $ mrgIte' cond (from a) (from b) - {-# INLINE mrgIte #-} - -- | Lifting of the 'SimpleMergeable' class to unary type constructors. -class (Mergeable1 u) => SimpleMergeable1 u where +class + (Mergeable1 u, forall a. (SimpleMergeable a) => (SimpleMergeable (u a))) => + SimpleMergeable1 u + where -- | Lift 'mrgIte' through the type constructor. -- -- >>> liftMrgIte mrgIte "a" (Identity "b") (Identity "c") :: Identity SymInteger @@ -150,175 +150,266 @@ -- -- >>> mrgIte1 "a" (Identity "b") (Identity "c") :: Identity SymInteger -- Identity (ite a b c) -mrgIte1 :: (SimpleMergeable1 u, SimpleMergeable a) => SymBool -> u a -> u a -> u a +mrgIte1 :: + (SimpleMergeable1 u, SimpleMergeable a) => SymBool -> u a -> u a -> u a mrgIte1 = liftMrgIte mrgIte {-# INLINE mrgIte1 #-} -- | Lifting of the 'SimpleMergeable' class to binary type constructors. -class (Mergeable2 u) => SimpleMergeable2 u where +class + (Mergeable2 u, forall a. (SimpleMergeable a) => SimpleMergeable1 (u a)) => + SimpleMergeable2 u + where -- | Lift 'mrgIte' through the type constructor. -- -- >>> liftMrgIte2 mrgIte mrgIte "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) -- ((ite a b d),(ite a c e)) - liftMrgIte2 :: (SymBool -> a -> a -> a) -> (SymBool -> b -> b -> b) -> SymBool -> u a b -> u a b -> u a b + liftMrgIte2 :: + (SymBool -> a -> a -> a) -> + (SymBool -> b -> b -> b) -> + SymBool -> + u a b -> + u a b -> + u a b -- | Lift the standard 'mrgIte' function through the type constructor. -- -- >>> mrgIte2 "a" ("b", "c") ("d", "e") :: (SymInteger, SymBool) -- ((ite a b d),(ite a c e)) -mrgIte2 :: (SimpleMergeable2 u, SimpleMergeable a, SimpleMergeable b) => SymBool -> u a b -> u a b -> u a b +mrgIte2 :: + (SimpleMergeable2 u, SimpleMergeable a, SimpleMergeable b) => + SymBool -> + u a b -> + u a b -> + u a b mrgIte2 = liftMrgIte2 mrgIte mrgIte {-# INLINE mrgIte2 #-} +-- | The arguments to the generic simple merging function. +data family SimpleMergeableArgs arity a :: Type + +data instance SimpleMergeableArgs Arity0 _ = SimpleMergeableArgs0 + +newtype instance SimpleMergeableArgs Arity1 a + = SimpleMergeableArgs1 (SymBool -> a -> a -> a) + +-- | Generic 'SimpleMergeable' class. +class GSimpleMergeable arity f where + gmrgIte :: SimpleMergeableArgs arity a -> SymBool -> f a -> f a -> f a + +instance GSimpleMergeable arity V1 where + gmrgIte _ _ t _ = t + {-# INLINE gmrgIte #-} + +instance (GSimpleMergeable arity U1) where + gmrgIte _ _ t _ = t + {-# INLINE gmrgIte #-} + +instance + (GSimpleMergeable arity a, GSimpleMergeable arity b) => + (GSimpleMergeable arity (a :*: b)) + where + gmrgIte args cond (a1 :*: a2) (b1 :*: b2) = + gmrgIte args cond a1 b1 :*: gmrgIte args cond a2 b2 + {-# INLINE gmrgIte #-} + +instance (GSimpleMergeable arity a) => (GSimpleMergeable arity (M1 i c a)) where + gmrgIte args cond (M1 a) (M1 b) = M1 $ gmrgIte args cond a b + {-# INLINE gmrgIte #-} + +instance (SimpleMergeable c) => (GSimpleMergeable arity (K1 i c)) where + gmrgIte _ cond (K1 a) (K1 b) = K1 $ mrgIte cond a b + {-# INLINE gmrgIte #-} + +instance GSimpleMergeable Arity1 Par1 where + gmrgIte (SimpleMergeableArgs1 f) cond (Par1 l) (Par1 r) = Par1 $ f cond l r + {-# INLINE gmrgIte #-} + +instance (SimpleMergeable1 f) => GSimpleMergeable Arity1 (Rec1 f) where + gmrgIte (SimpleMergeableArgs1 f) cond (Rec1 l) (Rec1 r) = + Rec1 $ liftMrgIte f cond l r + {-# INLINE gmrgIte #-} + +instance + (SimpleMergeable1 f, GSimpleMergeable Arity1 g) => + GSimpleMergeable Arity1 (f :.: g) + where + gmrgIte targs cond (Comp1 l) (Comp1 r) = + Comp1 $ liftMrgIte (gmrgIte targs) cond l r + {-# INLINE gmrgIte #-} + +instance + (Generic a, GSimpleMergeable Arity0 (Rep a), GMergeable Arity0 (Rep a)) => + SimpleMergeable (Default a) + where + mrgIte cond (Default a) (Default b) = + Default $ genericMrgIte cond a b + {-# INLINE mrgIte #-} + +-- | Generic 'mrgIte' function. +genericMrgIte :: + (Generic a, GSimpleMergeable Arity0 (Rep a)) => + SymBool -> + a -> + a -> + a +genericMrgIte cond a b = + to $ gmrgIte SimpleMergeableArgs0 cond (from a) (from b) +{-# INLINE genericMrgIte #-} + +instance + ( Generic1 f, + GSimpleMergeable Arity1 (Rep1 f), + GMergeable Arity1 (Rep1 f), + SimpleMergeable a + ) => + SimpleMergeable (Default1 f a) + where + mrgIte = mrgIte1 + {-# INLINE mrgIte #-} + +instance + (Generic1 f, GSimpleMergeable Arity1 (Rep1 f), GMergeable Arity1 (Rep1 f)) => + SimpleMergeable1 (Default1 f) + where + liftMrgIte f c (Default1 l) (Default1 r) = + Default1 $ genericLiftMrgIte f c l r + {-# INLINE liftMrgIte #-} + +-- | Generic 'liftMrgIte' function. +genericLiftMrgIte :: + (Generic1 f, GSimpleMergeable Arity1 (Rep1 f)) => + (SymBool -> a -> a -> a) -> + SymBool -> + f a -> + f a -> + f a +genericLiftMrgIte f c l r = + to1 $ gmrgIte (SimpleMergeableArgs1 f) c (from1 l) (from1 r) +{-# INLINE genericLiftMrgIte #-} + -- | Special case of the 'Mergeable1' and 'SimpleMergeable1' class for type -- constructors that are 'SimpleMergeable' when applied to any 'Mergeable' -- types. -- -- This type class is used to generalize the 'mrgIf' function to other -- containers, for example, monad transformer transformed Unions. -class (SimpleMergeable1 u, TryMerge u) => UnionMergeable1 (u :: Type -> Type) where - -- | Symbolic @if@ control flow with the result merged with some merge strategy. +class + ( SimpleMergeable1 u, + forall a. (Mergeable a) => SimpleMergeable (u a), + TryMerge u + ) => + SymBranching (u :: Type -> Type) + where + -- | Symbolic @if@ control flow with the result merged with some merge + -- strategy. -- - -- >>> mrgIfWithStrategy rootStrategy "a" (mrgSingle "b") (return "c") :: UnionM SymInteger + -- >>> mrgIfWithStrategy rootStrategy "a" (mrgSingle "b") (return "c") :: Union SymInteger -- {(ite a b c)} -- -- __Note:__ Be careful to call this directly in your code. - -- The supplied merge strategy should be consistent with the type's root merge strategy, - -- or some internal invariants would be broken and the program can crash. + -- The supplied merge strategy should be consistent with the type's root merge + -- strategy, or some internal invariants would be broken and the program can + -- crash. -- - -- This function is to be called when the 'Mergeable' constraint can not be resolved, - -- e.g., the merge strategy for the contained type is given with 'Mergeable1'. - -- In other cases, 'mrgIf' is usually a better alternative. + -- This function is to be called when the 'Mergeable' constraint can not be + -- resolved, e.g., the merge strategy for the contained type is given with + -- 'Mergeable1'. In other cases, 'mrgIf' is usually a better alternative. mrgIfWithStrategy :: MergingStrategy a -> SymBool -> u a -> u a -> u a + -- | Symbolic @if@ control flow with the result. + -- + -- This function does not need a merging strategy, and it will merge the + -- result only if any of the branches is merged. mrgIfPropagatedStrategy :: SymBool -> u a -> u a -> u a -mergeWithStrategy :: (UnionMergeable1 m) => MergingStrategy a -> m a -> m a +-- | Try to merge the container with a given merge strategy. +mergeWithStrategy :: (SymBranching m) => MergingStrategy a -> m a -> m a mergeWithStrategy = tryMergeWithStrategy {-# INLINE mergeWithStrategy #-} -- | Try to merge the container with the root strategy. -merge :: (UnionMergeable1 m, Mergeable a) => m a -> m a +merge :: (SymBranching m, Mergeable a) => m a -> m a merge = mergeWithStrategy rootStrategy {-# INLINE merge #-} --- | Symbolic @if@ control flow with the result merged with the type's root merge strategy. +-- | Symbolic @if@ control flow with the result merged with the type's root +-- merge strategy. -- -- Equivalent to @'mrgIfWithStrategy' 'rootStrategy'@. -- --- >>> mrgIf "a" (return "b") (return "c") :: UnionM SymInteger +-- >>> mrgIf "a" (return "b") (return "c") :: Union SymInteger -- {(ite a b c)} -mrgIf :: (UnionMergeable1 u, Mergeable a) => SymBool -> u a -> u a -> u a +mrgIf :: (SymBranching u, Mergeable a) => SymBool -> u a -> u a -> u a mrgIf = mrgIfWithStrategy rootStrategy {-# INLINE mrgIf #-} -instance SimpleMergeable () where - mrgIte _ t _ = t - {-# INLINE mrgIte #-} - -instance (SimpleMergeable a, SimpleMergeable b) => SimpleMergeable (a, b) where - mrgIte cond (a1, b1) (a2, b2) = (mrgIte cond a1 a2, mrgIte cond b1 b2) - {-# INLINE mrgIte #-} +deriveBuiltins + (ViaDefault ''SimpleMergeable) + [''SimpleMergeable] + [ ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Down + ] -instance (SimpleMergeable a) => SimpleMergeable1 ((,) a) where - liftMrgIte mb cond (a1, b1) (a2, b2) = (mrgIte cond a1 a2, mb cond b1 b2) - {-# INLINE liftMrgIte #-} +deriveBuiltins + (ViaDefault1 ''SimpleMergeable1) + [''SimpleMergeable, ''SimpleMergeable1] + [ ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Down + ] instance SimpleMergeable2 (,) where liftMrgIte2 ma mb cond (a1, b1) (a2, b2) = (ma cond a1 a2, mb cond b1 b2) {-# INLINE liftMrgIte2 #-} -instance - (SimpleMergeable a, SimpleMergeable b, SimpleMergeable c) => - SimpleMergeable (a, b, c) - where - mrgIte cond (a1, b1, c1) (a2, b2, c2) = (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2) - {-# INLINE mrgIte #-} - -instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d - ) => - SimpleMergeable (a, b, c, d) - where - mrgIte cond (a1, b1, c1, d1) (a2, b2, c2, d2) = - (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2) - {-# INLINE mrgIte #-} - -instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d, - SimpleMergeable e - ) => - SimpleMergeable (a, b, c, d, e) - where - mrgIte cond (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) = - (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2, mrgIte cond e1 e2) - {-# INLINE mrgIte #-} - -instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d, - SimpleMergeable e, - SimpleMergeable f - ) => - SimpleMergeable (a, b, c, d, e, f) - where - mrgIte cond (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) = - (mrgIte cond a1 a2, mrgIte cond b1 b2, mrgIte cond c1 c2, mrgIte cond d1 d2, mrgIte cond e1 e2, mrgIte cond f1 f2) - {-# INLINE mrgIte #-} - -instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d, - SimpleMergeable e, - SimpleMergeable f, - SimpleMergeable g - ) => - SimpleMergeable (a, b, c, d, e, f, g) - where - mrgIte cond (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) = - ( mrgIte cond a1 a2, - mrgIte cond b1 b2, - mrgIte cond c1 c2, - mrgIte cond d1 d2, - mrgIte cond e1 e2, - mrgIte cond f1 f2, - mrgIte cond g1 g2 - ) - {-# INLINE mrgIte #-} +instance (SimpleMergeable a) => SimpleMergeable2 ((,,) a) where + liftMrgIte2 mb mc cond (a1, b1, c1) (a2, b2, c2) = + (mrgIte cond a1 a2, mb cond b1 b2, mc cond c1 c2) + {-# INLINE liftMrgIte2 #-} instance - ( SimpleMergeable a, - SimpleMergeable b, - SimpleMergeable c, - SimpleMergeable d, - SimpleMergeable e, - SimpleMergeable f, - SimpleMergeable g, - SimpleMergeable h - ) => - SimpleMergeable (a, b, c, d, e, f, g, h) + (SimpleMergeable a, SimpleMergeable b) => + SimpleMergeable2 ((,,,) a b) where - mrgIte cond (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) = - ( mrgIte cond a1 a2, - mrgIte cond b1 b2, - mrgIte cond c1 c2, - mrgIte cond d1 d2, - mrgIte cond e1 e2, - mrgIte cond f1 f2, - mrgIte cond g1 g2, - mrgIte cond h1 h2 - ) - {-# INLINE mrgIte #-} + liftMrgIte2 mc md cond (a1, b1, c1, d1) (a2, b2, c2, d2) = + (mrgIte cond a1 a2, mrgIte cond b1 b2, mc cond c1 c2, md cond d1 d2) + {-# INLINE liftMrgIte2 #-} instance (SimpleMergeable b) => SimpleMergeable (a -> b) where mrgIte = mrgIte1 @@ -328,15 +419,20 @@ liftMrgIte ms cond t f v = ms cond (t v) (f v) {-# INLINE liftMrgIte #-} -instance (UnionMergeable1 m, Mergeable a) => SimpleMergeable (MaybeT m a) where +instance SimpleMergeable2 (->) where + liftMrgIte2 _ ms cond t f v = ms cond (t v) (f v) + {-# INLINE liftMrgIte2 #-} + +-- MaybeT +instance (SymBranching m, Mergeable a) => SimpleMergeable (MaybeT m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} -instance (UnionMergeable1 m) => SimpleMergeable1 (MaybeT m) where +instance (SymBranching m) => SimpleMergeable1 (MaybeT m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} -instance (UnionMergeable1 m) => UnionMergeable1 (MaybeT m) where +instance (SymBranching m) => SymBranching (MaybeT m) where mrgIfWithStrategy strategy cond (MaybeT l) (MaybeT r) = MaybeT $ mrgIfWithStrategy (liftRootStrategy strategy) cond l r {-# INLINE mrgIfWithStrategy #-} @@ -344,23 +440,24 @@ MaybeT $ mrgIfPropagatedStrategy cond l r {-# INLINE mrgIfPropagatedStrategy #-} +-- ExceptT instance - (UnionMergeable1 m, Mergeable e, Mergeable a) => + (SymBranching m, Mergeable e, Mergeable a) => SimpleMergeable (ExceptT e m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} instance - (UnionMergeable1 m, Mergeable e) => + (SymBranching m, Mergeable e) => SimpleMergeable1 (ExceptT e m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} instance - (UnionMergeable1 m, Mergeable e) => - UnionMergeable1 (ExceptT e m) + (SymBranching m, Mergeable e) => + SymBranching (ExceptT e m) where mrgIfWithStrategy s cond (ExceptT t) (ExceptT f) = ExceptT $ mrgIfWithStrategy (liftRootStrategy s) cond t f @@ -369,23 +466,24 @@ ExceptT $ mrgIfPropagatedStrategy cond t f {-# INLINE mrgIfPropagatedStrategy #-} +-- StateT instance - (Mergeable s, Mergeable a, UnionMergeable1 m) => + (Mergeable s, Mergeable a, SymBranching m) => SimpleMergeable (StateLazy.StateT s m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} instance - (Mergeable s, UnionMergeable1 m) => + (Mergeable s, SymBranching m) => SimpleMergeable1 (StateLazy.StateT s m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} instance - (Mergeable s, UnionMergeable1 m) => - UnionMergeable1 (StateLazy.StateT s m) + (Mergeable s, SymBranching m) => + SymBranching (StateLazy.StateT s m) where mrgIfWithStrategy s cond (StateLazy.StateT t) (StateLazy.StateT f) = StateLazy.StateT $ \v -> @@ -400,22 +498,22 @@ {-# INLINE mrgIfPropagatedStrategy #-} instance - (Mergeable s, Mergeable a, UnionMergeable1 m) => + (Mergeable s, Mergeable a, SymBranching m) => SimpleMergeable (StateStrict.StateT s m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} instance - (Mergeable s, UnionMergeable1 m) => + (Mergeable s, SymBranching m) => SimpleMergeable1 (StateStrict.StateT s m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} instance - (Mergeable s, UnionMergeable1 m) => - UnionMergeable1 (StateStrict.StateT s m) + (Mergeable s, SymBranching m) => + SymBranching (StateStrict.StateT s m) where mrgIfWithStrategy s cond (StateStrict.StateT t) (StateStrict.StateT f) = StateStrict.StateT $ @@ -426,23 +524,24 @@ StateStrict.StateT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) {-# INLINE mrgIfPropagatedStrategy #-} +-- WriterT instance - (Mergeable s, Mergeable a, UnionMergeable1 m, Monoid s) => + (Mergeable s, Mergeable a, SymBranching m, Monoid s) => SimpleMergeable (WriterLazy.WriterT s m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} instance - (Mergeable s, UnionMergeable1 m, Monoid s) => + (Mergeable s, SymBranching m, Monoid s) => SimpleMergeable1 (WriterLazy.WriterT s m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} instance - (Mergeable s, UnionMergeable1 m, Monoid s) => - UnionMergeable1 (WriterLazy.WriterT s m) + (Mergeable s, SymBranching m, Monoid s) => + SymBranching (WriterLazy.WriterT s m) where mrgIfWithStrategy s cond (WriterLazy.WriterT t) (WriterLazy.WriterT f) = WriterLazy.WriterT $ @@ -453,48 +552,52 @@ {-# INLINE mrgIfPropagatedStrategy #-} instance - (Mergeable s, Mergeable a, UnionMergeable1 m, Monoid s) => + (Mergeable s, Mergeable a, SymBranching m, Monoid s) => SimpleMergeable (WriterStrict.WriterT s m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} instance - (Mergeable s, UnionMergeable1 m, Monoid s) => + (Mergeable s, SymBranching m, Monoid s) => SimpleMergeable1 (WriterStrict.WriterT s m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} instance - (Mergeable s, UnionMergeable1 m, Monoid s) => - UnionMergeable1 (WriterStrict.WriterT s m) + (Mergeable s, SymBranching m, Monoid s) => + SymBranching (WriterStrict.WriterT s m) where mrgIfWithStrategy s cond (WriterStrict.WriterT t) (WriterStrict.WriterT f) = WriterStrict.WriterT $ mrgIfWithStrategy (liftRootStrategy2 s rootStrategy) cond t f {-# INLINE mrgIfWithStrategy #-} - mrgIfPropagatedStrategy cond (WriterStrict.WriterT t) (WriterStrict.WriterT f) = - WriterStrict.WriterT $ mrgIfPropagatedStrategy cond t f + mrgIfPropagatedStrategy + cond + (WriterStrict.WriterT t) + (WriterStrict.WriterT f) = + WriterStrict.WriterT $ mrgIfPropagatedStrategy cond t f {-# INLINE mrgIfPropagatedStrategy #-} +-- ReaderT instance - (Mergeable a, UnionMergeable1 m) => + (Mergeable a, SymBranching m) => SimpleMergeable (ReaderT s m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} instance - (UnionMergeable1 m) => + (SymBranching m) => SimpleMergeable1 (ReaderT s m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} instance - (UnionMergeable1 m) => - UnionMergeable1 (ReaderT s m) + (SymBranching m) => + SymBranching (ReaderT s m) where mrgIfWithStrategy s cond (ReaderT t) (ReaderT f) = ReaderT $ \v -> mrgIfWithStrategy s cond (t v) (f v) @@ -503,26 +606,19 @@ ReaderT $ \v -> mrgIfPropagatedStrategy cond (t v) (f v) {-# INLINE mrgIfPropagatedStrategy #-} -instance (SimpleMergeable a) => SimpleMergeable (Identity a) where - mrgIte = mrgIte1 - {-# INLINE mrgIte #-} - -instance SimpleMergeable1 Identity where - liftMrgIte mite cond (Identity l) (Identity r) = Identity $ mite cond l r - {-# INLINE liftMrgIte #-} - +-- IdentityT instance - (UnionMergeable1 m, Mergeable a) => + (SymBranching m, Mergeable a) => SimpleMergeable (IdentityT m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} -instance (UnionMergeable1 m) => SimpleMergeable1 (IdentityT m) where +instance (SymBranching m) => SimpleMergeable1 (IdentityT m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} -instance (UnionMergeable1 m) => UnionMergeable1 (IdentityT m) where +instance (SymBranching m) => SymBranching (IdentityT m) where mrgIfWithStrategy s cond (IdentityT l) (IdentityT r) = IdentityT $ mrgIfWithStrategy s cond l r {-# INLINE mrgIfWithStrategy #-} @@ -530,15 +626,16 @@ IdentityT $ mrgIfPropagatedStrategy cond l r {-# INLINE mrgIfPropagatedStrategy #-} -instance (UnionMergeable1 m, Mergeable r) => SimpleMergeable (ContT r m a) where +-- ContT +instance (SymBranching m, Mergeable r) => SimpleMergeable (ContT r m a) where mrgIte cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c) {-# INLINE mrgIte #-} -instance (UnionMergeable1 m, Mergeable r) => SimpleMergeable1 (ContT r m) where +instance (SymBranching m, Mergeable r) => SimpleMergeable1 (ContT r m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} -instance (UnionMergeable1 m, Mergeable r) => UnionMergeable1 (ContT r m) where +instance (SymBranching m, Mergeable r) => SymBranching (ContT r m) where mrgIfWithStrategy _ cond (ContT l) (ContT r) = ContT $ \c -> mrgIf cond (l c) (r c) {-# INLINE mrgIfWithStrategy #-} @@ -546,23 +643,24 @@ ContT $ \c -> mrgIfPropagatedStrategy cond (l c) (r c) {-# INLINE mrgIfPropagatedStrategy #-} +-- RWST instance - (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionMergeable1 m) => + (Mergeable s, Mergeable w, Monoid w, Mergeable a, SymBranching m) => SimpleMergeable (RWSLazy.RWST r w s m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} instance - (Mergeable s, Mergeable w, Monoid w, UnionMergeable1 m) => + (Mergeable s, Mergeable w, Monoid w, SymBranching m) => SimpleMergeable1 (RWSLazy.RWST r w s m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} instance - (Mergeable s, Mergeable w, Monoid w, UnionMergeable1 m) => - UnionMergeable1 (RWSLazy.RWST r w s m) + (Mergeable s, Mergeable w, Monoid w, SymBranching m) => + SymBranching (RWSLazy.RWST r w s m) where mrgIfWithStrategy ms cond (RWSLazy.RWST t) (RWSLazy.RWST f) = RWSLazy.RWST $ \r s -> @@ -577,22 +675,22 @@ {-# INLINE mrgIfPropagatedStrategy #-} instance - (Mergeable s, Mergeable w, Monoid w, Mergeable a, UnionMergeable1 m) => + (Mergeable s, Mergeable w, Monoid w, Mergeable a, SymBranching m) => SimpleMergeable (RWSStrict.RWST r w s m a) where mrgIte = mrgIf {-# INLINE mrgIte #-} instance - (Mergeable s, Mergeable w, Monoid w, UnionMergeable1 m) => + (Mergeable s, Mergeable w, Monoid w, SymBranching m) => SimpleMergeable1 (RWSStrict.RWST r w s m) where liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) {-# INLINE liftMrgIte #-} instance - (Mergeable s, Mergeable w, Monoid w, UnionMergeable1 m) => - UnionMergeable1 (RWSStrict.RWST r w s m) + (Mergeable s, Mergeable w, Monoid w, SymBranching m) => + SymBranching (RWSStrict.RWST r w s m) where mrgIfWithStrategy ms cond (RWSStrict.RWST t) (RWSStrict.RWST f) = RWSStrict.RWST $ \r s -> @@ -606,6 +704,110 @@ RWSStrict.RWST $ \r s -> mrgIfPropagatedStrategy cond (t r s) (f r s) {-# INLINE mrgIfPropagatedStrategy #-} +-- Product +deriving via + (Default (Product l r a)) + instance + (SimpleMergeable (l a), SimpleMergeable (r a)) => + SimpleMergeable (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (SimpleMergeable1 l, SimpleMergeable1 r) => SimpleMergeable1 (Product l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (SimpleMergeable (f (g a))) => + SimpleMergeable (Compose f g a) + +instance + (SimpleMergeable1 f, SimpleMergeable1 g) => + SimpleMergeable1 (Compose f g) + where + liftMrgIte m cond (Compose l) (Compose r) = + Compose $ liftMrgIte (liftMrgIte m) cond l r + +-- Const +deriving via + (Default (Const a b)) + instance + (SimpleMergeable a) => SimpleMergeable (Const a b) + +deriving via + (Default1 (Const a)) + instance + (SimpleMergeable a) => SimpleMergeable1 (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (SimpleMergeable (f a)) => SimpleMergeable (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (SimpleMergeable1 f) => SimpleMergeable1 (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (SimpleMergeable (f a)) => SimpleMergeable (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (SimpleMergeable1 f) => SimpleMergeable1 (Ap f) + +-- Endo +instance (SimpleMergeable a) => SimpleMergeable (Endo a) where + mrgIte = mrgIte1 + {-# INLINE mrgIte #-} + +instance SimpleMergeable1 Endo where + liftMrgIte m cond (Endo l) (Endo r) = Endo $ liftMrgIte m cond l r + {-# INLINE liftMrgIte #-} + +-- Generic +deriving via (Default (U1 p)) instance SimpleMergeable (U1 p) + +deriving via (Default (V1 p)) instance SimpleMergeable (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (SimpleMergeable c) => SimpleMergeable (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (SimpleMergeable (f p)) => SimpleMergeable (M1 i c f p) + +deriving via + (Default ((f :*: g) p)) + instance + (SimpleMergeable (f p), SimpleMergeable (g p)) => + SimpleMergeable ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (SimpleMergeable p) => SimpleMergeable (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (SimpleMergeable (f p)) => SimpleMergeable (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (SimpleMergeable (f (g p))) => SimpleMergeable ((f :.: g) p) + #define SIMPLE_MERGEABLE_SIMPLE(symtype) \ instance SimpleMergeable symtype where \ mrgIte = symIte; \ @@ -635,6 +837,3 @@ instance (ValidFP eb sb) => SimpleMergeable (SymFP eb sb) where mrgIte = symIte {-# INLINE mrgIte #-} - --- Exception -deriving via (Default AssertionError) instance SimpleMergeable AssertionError diff --git a/src/Grisette/Internal/Core/Data/Class/Solvable.hs b/src/Grisette/Internal/Core/Data/Class/Solvable.hs --- a/src/Grisette/Internal/Core/Data/Class/Solvable.hs +++ b/src/Grisette/Internal/Core/Data/Class/Solvable.hs @@ -131,7 +131,7 @@ slocsym nm = [||ssym $$(withLoc nm)||] -- | Generate indexed symbolic variables. The file location will be attached to --- identifier. +-- the identifier. -- -- >>> $$(ilocsym "a" 1) :: SymBool -- a::...@1 diff --git a/src/Grisette/Internal/Core/Data/Class/Solver.hs b/src/Grisette/Internal/Core/Data/Class/Solver.hs --- a/src/Grisette/Internal/Core/Data/Class/Solver.hs +++ b/src/Grisette/Internal/Core/Data/Class/Solver.hs @@ -60,8 +60,8 @@ import Data.Hashable (Hashable) import Data.Maybe (fromJust) import GHC.Generics (Generic) -import Grisette.Internal.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), +import Grisette.Internal.Core.Data.Class.ExtractSym + ( ExtractSym (extractSym), ) import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||))) import Grisette.Internal.Core.Data.Class.PlainUnion @@ -116,6 +116,8 @@ monadicSolverAssert :: SymBool -> m () monadicSolverCheckSat :: m (Either SolvingFailure Model) +-- | Solve a single formula with a monadic solver. Find an assignment to it to +-- make it true. monadicSolverSolve :: (MonadicSolver m) => SymBool -> m (Either SolvingFailure Model) monadicSolverSolve formula = do @@ -162,7 +164,7 @@ -- -- The solver keeps all the assertions used in the previous commands: -- - -- >>> solver <- newSolver (precise z3) + -- >>> solver <- newSolver z3 -- >>> solverSolve solver "a" -- Right (Model {a -> True :: Bool}) -- >>> solverSolve solver $ symNot "a" @@ -184,6 +186,7 @@ -- | Force terminate the solver, do not wait for the last command to finish. solverForceTerminate :: handle -> IO () +-- | Solve a single formula. Find an assignment to it to make it true. solverSolve :: (Solver handle) => handle -> SymBool -> IO (Either SolvingFailure Model) solverSolve solver formula = do @@ -211,7 +214,7 @@ (models, err) <- go solver model numOfModelRequested return (model : models, err) where - allSymbols = extractSymbolics formula :: SymbolSet + allSymbols = extractSym formula :: SymbolSet go solver prevModel n | n <= 1 = return ([], ResultNumLimitReached) | otherwise = do @@ -308,9 +311,9 @@ -- | Solve a single formula. Find an assignment to it to make it true. -- --- >>> solve (precise z3) ("a" .&& ("b" :: SymInteger) .== 1) +-- >>> solve z3 ("a" .&& ("b" :: SymInteger) .== 1) -- Right (Model {a -> True :: Bool, b -> 1 :: Integer}) --- >>> solve (precise z3) ("a" .&& symNot "a") +-- >>> solve z3 ("a" .&& symNot "a") -- Left Unsat solve :: (ConfigurableSolver config handle) => @@ -324,7 +327,7 @@ -- | Solve a single formula while returning multiple models to make it true. -- The maximum number of desired models are given. -- --- > >>> solveMulti (precise z3) 4 ("a" .|| "b") +-- > >>> solveMulti z3 4 ("a" .|| "b") -- > [Model {a -> True :: Bool, b -> False :: Bool},Model {a -> False :: Bool, b -> True :: Bool},Model {a -> True :: Bool, b -> True :: Bool}] solveMulti :: (ConfigurableSolver config handle) => @@ -354,7 +357,7 @@ -- >>> import Control.Monad.Except -- >>> let x = "x" :: SymInteger -- >>> :{ --- res :: ExceptT AssertionError UnionM () +-- res :: ExceptT AssertionError Union () -- res = do -- symAssert $ x .> 0 -- constrain that x is positive -- symAssert $ x .< 2 -- constrain that x is less than 2 @@ -365,7 +368,7 @@ -- translate _ = con True -- non-errors are desirable -- :} -- --- >>> solveExcept (precise z3) translate res +-- >>> solveExcept z3 translate res -- Right (Model {x -> 1 :: Integer}) solveExcept :: ( UnionWithExcept t u e v, diff --git a/src/Grisette/Internal/Core/Data/Class/SubstSym.hs b/src/Grisette/Internal/Core/Data/Class/SubstSym.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SubstSym.hs @@ -0,0 +1,617 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.SubstSym +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SubstSym + ( -- * Substituting symbolic constants + SubstSym (..), + SubstSym1 (..), + substSym1, + SubstSym2 (..), + substSym2, + + -- * Generic 'SubstSym' + SubstSymArgs (..), + GSubstSym (..), + genericSubstSym, + genericLiftSubstSym, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default, unDefault), + Default1 (Default1, unDefault1), + Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Generics.Deriving.Instances () +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->)) +import Grisette.Internal.SymPrim.Prim.Term + ( LinkedRep (underlyingTerm), + SupportedPrim, + TypedSymbol, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) +import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim + +-- | Substitution of symbols (symbolic constants) to a symbolic value. +-- +-- >>> a = "a" :: TypedSymbol Bool +-- >>> v = "x" .&& "y" :: SymBool +-- >>> substSym a v (["a" .&& "b", "a"] :: [SymBool]) +-- [(&& (&& x y) b),(&& x y)] +-- +-- __Note 1:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SubstSym via (Default X) +class SubstSym a where + -- Substitute a symbolic constant to some symbolic value + -- + -- >>> substSym "a" ("c" .&& "d" :: Sym Bool) ["a" .&& "b" :: Sym Bool, "a"] + -- [(&& (&& c d) b),(&& c d)] + substSym :: (LinkedRep cb sb) => TypedSymbol cb -> sb -> a -> a + +-- | Lifting of 'SubstSym' to unary type constructors. +class + (forall a. (SubstSym a) => SubstSym (f a)) => + SubstSym1 f + where + -- | Lift a symbol substitution function to unary type constructors. + liftSubstSym :: + (LinkedRep cb sb) => + (TypedSymbol cb -> sb -> a -> a) -> + TypedSymbol cb -> + sb -> + f a -> + f a + +-- | Lifting the standard 'substSym' to unary type constructors. +substSym1 :: + (SubstSym1 f, SubstSym a, LinkedRep cb sb) => + TypedSymbol cb -> + sb -> + f a -> + f a +substSym1 = liftSubstSym substSym + +-- | Lifting of 'SubstSym' to binary type constructors. +class + (forall a. (SubstSym a) => SubstSym1 (f a)) => + SubstSym2 f + where + -- | Lift a symbol substitution function to binary type constructors. + liftSubstSym2 :: + (LinkedRep cb sb) => + (TypedSymbol cb -> sb -> a -> a) -> + (TypedSymbol cb -> sb -> b -> b) -> + TypedSymbol cb -> + sb -> + f a b -> + f a b + +-- | Lifting the standard 'substSym' to binary type constructors. +substSym2 :: + (SubstSym2 f, SubstSym a, SubstSym b, LinkedRep cb sb) => + TypedSymbol cb -> + sb -> + f a b -> + f a b +substSym2 = liftSubstSym2 substSym substSym + +-- Derivations + +-- | The arguments to the generic 'substSym' function. +data family SubstSymArgs arity a cb sb :: Type + +data instance SubstSymArgs Arity0 _ _ _ = SubstSymArgs0 + +newtype instance SubstSymArgs Arity1 a cb sb + = SubstSymArgs1 (TypedSymbol cb -> sb -> a -> a) + +-- | The class of types where we can generically substitute the symbols in a +-- value. +class GSubstSym arity f where + gsubstSym :: + (LinkedRep cb sb) => + SubstSymArgs arity a cb sb -> + TypedSymbol cb -> + sb -> + f a -> + f a + +instance GSubstSym arity V1 where + gsubstSym _ _ _ = id + {-# INLINE gsubstSym #-} + +instance GSubstSym arity U1 where + gsubstSym _ _ _ = id + {-# INLINE gsubstSym #-} + +instance (SubstSym a) => GSubstSym arity (K1 i a) where + gsubstSym _ sym val (K1 v) = K1 $ substSym sym val v + {-# INLINE gsubstSym #-} + +instance (GSubstSym arity a) => GSubstSym arity (M1 i c a) where + gsubstSym args sym val (M1 v) = M1 $ gsubstSym args sym val v + {-# INLINE gsubstSym #-} + +instance (GSubstSym arity a, GSubstSym arity b) => GSubstSym arity (a :*: b) where + gsubstSym args sym val (a :*: b) = + gsubstSym args sym val a :*: gsubstSym args sym val b + {-# INLINE gsubstSym #-} + +instance (GSubstSym arity a, GSubstSym arity b) => GSubstSym arity (a :+: b) where + gsubstSym args sym val (L1 l) = L1 $ gsubstSym args sym val l + gsubstSym args sym val (R1 r) = R1 $ gsubstSym args sym val r + {-# INLINE gsubstSym #-} + +instance (SubstSym1 a) => GSubstSym Arity1 (Rec1 a) where + gsubstSym (SubstSymArgs1 f) sym val (Rec1 v) = + Rec1 $ liftSubstSym f sym val v + {-# INLINE gsubstSym #-} + +instance GSubstSym Arity1 Par1 where + gsubstSym (SubstSymArgs1 f) sym val (Par1 v) = Par1 $ f sym val v + {-# INLINE gsubstSym #-} + +instance + (SubstSym1 f, GSubstSym Arity1 g) => + GSubstSym Arity1 (f :.: g) + where + gsubstSym targs sym val (Comp1 x) = + Comp1 $ liftSubstSym (gsubstSym targs) sym val x + {-# INLINE gsubstSym #-} + +-- | Generic 'substSym' function. +genericSubstSym :: + (Generic a, GSubstSym Arity0 (Rep a), LinkedRep cb sb) => + TypedSymbol cb -> + sb -> + a -> + a +genericSubstSym sym val = + to . gsubstSym SubstSymArgs0 sym val . from +{-# INLINE genericSubstSym #-} + +-- | Generic 'liftSubstSym' function. +genericLiftSubstSym :: + (Generic1 f, GSubstSym Arity1 (Rep1 f), LinkedRep cb sb) => + (TypedSymbol cb -> sb -> a -> a) -> + TypedSymbol cb -> + sb -> + f a -> + f a +genericLiftSubstSym f sym val = + to1 . gsubstSym (SubstSymArgs1 f) sym val . from1 +{-# INLINE genericLiftSubstSym #-} + +instance + (Generic a, GSubstSym Arity0 (Rep a)) => + SubstSym (Default a) + where + substSym sym val = Default . genericSubstSym sym val . unDefault + {-# INLINE substSym #-} + +instance + (Generic1 f, GSubstSym Arity1 (Rep1 f), SubstSym a) => + SubstSym (Default1 f a) + where + substSym = substSym1 + {-# INLINE substSym #-} + +instance + (Generic1 f, GSubstSym Arity1 (Rep1 f)) => + SubstSym1 (Default1 f) + where + liftSubstSym f sym val = + Default1 . genericLiftSubstSym f sym val . unDefault1 + {-# INLINE liftSubstSym #-} + +#define CONCRETE_SUBSTITUTESYM(type) \ +instance SubstSym type where \ + substSym _ _ = id + +#define CONCRETE_SUBSTITUTESYM_BV(type) \ +instance (KnownNat n, 1 <= n) => SubstSym (type n) where \ + substSym _ _ = id + +#if 1 +CONCRETE_SUBSTITUTESYM(Bool) +CONCRETE_SUBSTITUTESYM(Integer) +CONCRETE_SUBSTITUTESYM(Char) +CONCRETE_SUBSTITUTESYM(Int) +CONCRETE_SUBSTITUTESYM(Int8) +CONCRETE_SUBSTITUTESYM(Int16) +CONCRETE_SUBSTITUTESYM(Int32) +CONCRETE_SUBSTITUTESYM(Int64) +CONCRETE_SUBSTITUTESYM(Word) +CONCRETE_SUBSTITUTESYM(Word8) +CONCRETE_SUBSTITUTESYM(Word16) +CONCRETE_SUBSTITUTESYM(Word32) +CONCRETE_SUBSTITUTESYM(Word64) +CONCRETE_SUBSTITUTESYM(Float) +CONCRETE_SUBSTITUTESYM(Double) +CONCRETE_SUBSTITUTESYM(B.ByteString) +CONCRETE_SUBSTITUTESYM(T.Text) +CONCRETE_SUBSTITUTESYM(Monoid.All) +CONCRETE_SUBSTITUTESYM(Monoid.Any) +CONCRETE_SUBSTITUTESYM(Ordering) +CONCRETE_SUBSTITUTESYM_BV(WordN) +CONCRETE_SUBSTITUTESYM_BV(IntN) +CONCRETE_SUBSTITUTESYM(FPRoundingMode) +#endif + +instance (ValidFP eb sb) => SubstSym (FP eb sb) where + substSym _ _ = id + +#define SUBSTITUTE_SYM_SIMPLE(symtype) \ +instance SubstSym symtype where \ + substSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t + +#define SUBSTITUTE_SYM_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SubstSym (symtype n) where \ + substSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t + +#define SUBSTITUTE_SYM_FUN(cop, op, cons) \ +instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ + SubstSym (op sa sb) where \ + substSym sym v (cons t) = cons $ substTerm sym (underlyingTerm v) t + +#if 1 +SUBSTITUTE_SYM_SIMPLE(SymBool) +SUBSTITUTE_SYM_SIMPLE(SymInteger) +SUBSTITUTE_SYM_BV(SymIntN) +SUBSTITUTE_SYM_BV(SymWordN) +SUBSTITUTE_SYM_FUN((=->), (=~>), SymTabularFun) +SUBSTITUTE_SYM_FUN((-->), (-~>), SymGeneralFun) +SUBSTITUTE_SYM_SIMPLE(SymFPRoundingMode) +#endif + +instance (ValidFP eb sb) => SubstSym (SymFP eb sb) where + substSym sym v (SymFP t) = SymFP $ substTerm sym (underlyingTerm v) t + +-- Instances +deriveBuiltins + (ViaDefault ''SubstSym) + [''SubstSym] + [ ''[], + ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +deriveBuiltins + (ViaDefault1 ''SubstSym1) + [''SubstSym, ''SubstSym1] + [ ''[], + ''Maybe, + ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +-- ExceptT +instance + (SubstSym1 m, SubstSym e, SubstSym a) => + SubstSym (ExceptT e m a) + where + substSym = substSym1 + {-# INLINE substSym #-} + +instance + (SubstSym1 m, SubstSym e) => + SubstSym1 (ExceptT e m) + where + liftSubstSym f sym val (ExceptT v) = + ExceptT $ liftSubstSym (liftSubstSym f) sym val v + {-# INLINE liftSubstSym #-} + +-- MaybeT +instance + (SubstSym1 m, SubstSym a) => + SubstSym (MaybeT m a) + where + substSym = substSym1 + {-# INLINE substSym #-} + +instance + (SubstSym1 m) => + SubstSym1 (MaybeT m) + where + liftSubstSym f sym val (MaybeT v) = + MaybeT $ liftSubstSym (liftSubstSym f) sym val v + {-# INLINE liftSubstSym #-} + +-- WriterT +instance + (SubstSym1 m, SubstSym a, SubstSym s) => + SubstSym (WriterLazy.WriterT s m a) + where + substSym = substSym1 + {-# INLINE substSym #-} + +instance + (SubstSym1 m, SubstSym s) => + SubstSym1 (WriterLazy.WriterT s m) + where + liftSubstSym f sym val (WriterLazy.WriterT v) = + WriterLazy.WriterT $ + liftSubstSym (liftSubstSym2 f substSym) sym val v + {-# INLINE liftSubstSym #-} + +instance + (SubstSym1 m, SubstSym a, SubstSym s) => + SubstSym (WriterStrict.WriterT s m a) + where + substSym = substSym1 + {-# INLINE substSym #-} + +instance + (SubstSym1 m, SubstSym s) => + SubstSym1 (WriterStrict.WriterT s m) + where + liftSubstSym f sym val (WriterStrict.WriterT v) = + WriterStrict.WriterT $ + liftSubstSym (liftSubstSym2 f substSym) sym val v + {-# INLINE liftSubstSym #-} + +-- IdentityT +instance + (SubstSym1 m, SubstSym a) => + SubstSym (IdentityT m a) + where + substSym = substSym1 + {-# INLINE substSym #-} + +instance (SubstSym1 m) => SubstSym1 (IdentityT m) where + liftSubstSym f sym val (IdentityT a) = + IdentityT $ liftSubstSym f sym val a + {-# INLINE liftSubstSym #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (SubstSym (l a), SubstSym (r a)) => SubstSym (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (SubstSym1 l, SubstSym1 r) => SubstSym1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (SubstSym (l a), SubstSym (r a)) => SubstSym (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (SubstSym1 l, SubstSym1 r) => SubstSym1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (SubstSym (f (g a))) => SubstSym (Compose f g a) + +instance + (SubstSym1 f, SubstSym1 g) => + SubstSym1 (Compose f g) + where + liftSubstSym f sym val (Compose x) = + Compose $ liftSubstSym (liftSubstSym f) sym val x + {-# INLINE liftSubstSym #-} + +-- Const +deriving via + (Default (Const a b)) + instance + (SubstSym a) => SubstSym (Const a b) + +deriving via + (Default1 (Const a)) + instance + (SubstSym a) => SubstSym1 (Const a) + +-- Alt +deriving via + (Default (Alt f a)) + instance + (SubstSym (f a)) => SubstSym (Alt f a) + +deriving via + (Default1 (Alt f)) + instance + (SubstSym1 f) => SubstSym1 (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (SubstSym (f a)) => SubstSym (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (SubstSym1 f) => SubstSym1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance SubstSym (U1 p) + +deriving via (Default (V1 p)) instance SubstSym (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (SubstSym c) => SubstSym (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (SubstSym (f p)) => SubstSym (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (SubstSym (f p), SubstSym (g p)) => SubstSym ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (SubstSym (f p), SubstSym (g p)) => SubstSym ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (SubstSym p) => SubstSym (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (SubstSym (f p)) => SubstSym (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (SubstSym (f (g p))) => SubstSym ((f :.: g) p) + +-- SubstSym2 +instance SubstSym2 Either where + liftSubstSym2 f _ sym val (Left x) = Left $ f sym val x + liftSubstSym2 _ g sym val (Right y) = Right $ g sym val y + {-# INLINE liftSubstSym2 #-} + +instance SubstSym2 (,) where + liftSubstSym2 f g sym val (x, y) = (f sym val x, g sym val y) + {-# INLINE liftSubstSym2 #-} + +instance (SubstSym a) => SubstSym2 ((,,) a) where + liftSubstSym2 f g sym val (x, y, z) = + (substSym sym val x, f sym val y, g sym val z) + {-# INLINE liftSubstSym2 #-} + +instance (SubstSym a, SubstSym b) => SubstSym2 ((,,,) a b) where + liftSubstSym2 f g sym val (x, y, z, w) = + (substSym sym val x, substSym sym val y, f sym val z, g sym val w) + {-# INLINE liftSubstSym2 #-} diff --git a/src/Grisette/Internal/Core/Data/Class/SubstituteSym.hs b/src/Grisette/Internal/Core/Data/Class/SubstituteSym.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core/Data/Class/SubstituteSym.hs +++ /dev/null @@ -1,329 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | --- Module : Grisette.Internal.Core.Data.Class.SubstituteSym --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.Data.Class.SubstituteSym - ( -- * Substituting symbolic constants - SubstituteSym (..), - SubstituteSym' (..), - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum) -import Data.Int (Int16, Int32, Int64, Int8) -import qualified Data.Text as T -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving - ( Default (Default, unDefault), - Generic (Rep, from, to), - K1 (K1), - M1 (M1), - U1, - V1, - type (:*:) ((:*:)), - type (:+:) (L1, R1), - ) -import Generics.Deriving.Instances () -import Grisette.Internal.SymPrim.BV (IntN, WordN) -import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) -import Grisette.Internal.SymPrim.GeneralFun (substTerm, type (-->)) -import Grisette.Internal.SymPrim.Prim.Term - ( LinkedRep (underlyingTerm), - SupportedPrim, - TypedSymbol, - ) -import Grisette.Internal.SymPrim.SymBV - ( SymIntN (SymIntN), - SymWordN (SymWordN), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) -import Grisette.Internal.SymPrim.SymFP - ( SymFP (SymFP), - SymFPRoundingMode (SymFPRoundingMode), - ) -import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>) (SymGeneralFun)) -import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) -import Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (SymTabularFun)) -import Grisette.Internal.SymPrim.TabularFun (type (=->)) - --- $setup --- >>> import Grisette.Core --- >>> import Grisette.SymPrim - --- | Substitution of symbolic constants. --- --- >>> a = "a" :: TypedSymbol Bool --- >>> v = "x" .&& "y" :: SymBool --- >>> substituteSym a v (["a" .&& "b", "a"] :: [SymBool]) --- [(&& (&& x y) b),(&& x y)] --- --- __Note 1:__ This type class can be derived for algebraic data types. --- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. --- --- > data X = ... deriving Generic deriving SubstituteSym via (Default X) -class SubstituteSym a where - -- Substitute a symbolic constant to some symbolic value - -- - -- >>> substituteSym "a" ("c" .&& "d" :: Sym Bool) ["a" .&& "b" :: Sym Bool, "a"] - -- [(&& (&& c d) b),(&& c d)] - substituteSym :: (LinkedRep cb sb) => TypedSymbol cb -> sb -> a -> a - -#define CONCRETE_SUBSTITUTESYM(type) \ -instance SubstituteSym type where \ - substituteSym _ _ = id - -#define CONCRETE_SUBSTITUTESYM_BV(type) \ -instance (KnownNat n, 1 <= n) => SubstituteSym (type n) where \ - substituteSym _ _ = id - -#if 1 -CONCRETE_SUBSTITUTESYM(Bool) -CONCRETE_SUBSTITUTESYM(Integer) -CONCRETE_SUBSTITUTESYM(Char) -CONCRETE_SUBSTITUTESYM(Int) -CONCRETE_SUBSTITUTESYM(Int8) -CONCRETE_SUBSTITUTESYM(Int16) -CONCRETE_SUBSTITUTESYM(Int32) -CONCRETE_SUBSTITUTESYM(Int64) -CONCRETE_SUBSTITUTESYM(Word) -CONCRETE_SUBSTITUTESYM(Word8) -CONCRETE_SUBSTITUTESYM(Word16) -CONCRETE_SUBSTITUTESYM(Word32) -CONCRETE_SUBSTITUTESYM(Word64) -CONCRETE_SUBSTITUTESYM(Float) -CONCRETE_SUBSTITUTESYM(Double) -CONCRETE_SUBSTITUTESYM(B.ByteString) -CONCRETE_SUBSTITUTESYM(T.Text) -CONCRETE_SUBSTITUTESYM_BV(WordN) -CONCRETE_SUBSTITUTESYM_BV(IntN) -CONCRETE_SUBSTITUTESYM(FPRoundingMode) -#endif - -instance (ValidFP eb sb) => SubstituteSym (FP eb sb) where - substituteSym _ _ = id - -instance SubstituteSym () where - substituteSym _ _ = id - --- Either -deriving via - (Default (Either a b)) - instance - ( SubstituteSym a, - SubstituteSym b - ) => - SubstituteSym (Either a b) - --- Maybe -deriving via (Default (Maybe a)) instance (SubstituteSym a) => SubstituteSym (Maybe a) - --- List -deriving via (Default [a]) instance (SubstituteSym a) => SubstituteSym [a] - --- (,) -deriving via - (Default (a, b)) - instance - (SubstituteSym a, SubstituteSym b) => - SubstituteSym (a, b) - --- (,,) -deriving via - (Default (a, b, c)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c - ) => - SubstituteSym (a, b, c) - --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d - ) => - SubstituteSym (a, b, c, d) - --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d, - SubstituteSym e - ) => - SubstituteSym (a, b, c, d, e) - --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d, - SubstituteSym e, - SubstituteSym f - ) => - SubstituteSym (a, b, c, d, e, f) - --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d, - SubstituteSym e, - SubstituteSym f, - SubstituteSym g - ) => - SubstituteSym (a, b, c, d, e, f, g) - --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( SubstituteSym a, - SubstituteSym b, - SubstituteSym c, - SubstituteSym d, - SubstituteSym e, - SubstituteSym f, - SubstituteSym g, - SubstituteSym h - ) => - SubstituteSym ((,,,,,,,) a b c d e f g h) - --- MaybeT -instance - (SubstituteSym (m (Maybe a))) => - SubstituteSym (MaybeT m a) - where - substituteSym sym val (MaybeT v) = MaybeT $ substituteSym sym val v - --- ExceptT -instance - (SubstituteSym (m (Either e a))) => - SubstituteSym (ExceptT e m a) - where - substituteSym sym val (ExceptT v) = ExceptT $ substituteSym sym val v - --- Sum -deriving via - (Default (Sum f g a)) - instance - (SubstituteSym (f a), SubstituteSym (g a)) => - SubstituteSym (Sum f g a) - --- WriterT -instance - (SubstituteSym (m (a, s))) => - SubstituteSym (WriterLazy.WriterT s m a) - where - substituteSym sym val (WriterLazy.WriterT v) = WriterLazy.WriterT $ substituteSym sym val v - -instance - (SubstituteSym (m (a, s))) => - SubstituteSym (WriterStrict.WriterT s m a) - where - substituteSym sym val (WriterStrict.WriterT v) = WriterStrict.WriterT $ substituteSym sym val v - --- Identity -instance (SubstituteSym a) => SubstituteSym (Identity a) where - substituteSym sym val (Identity a) = Identity $ substituteSym sym val a - --- IdentityT -instance (SubstituteSym (m a)) => SubstituteSym (IdentityT m a) where - substituteSym sym val (IdentityT a) = IdentityT $ substituteSym sym val a - -#define SUBSTITUTE_SYM_SIMPLE(symtype) \ -instance SubstituteSym symtype where \ - substituteSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t - -#define SUBSTITUTE_SYM_BV(symtype) \ -instance (KnownNat n, 1 <= n) => SubstituteSym (symtype n) where \ - substituteSym sym v (symtype t) = symtype $ substTerm sym (underlyingTerm v) t - -#define SUBSTITUTE_SYM_FUN(cop, op, cons) \ -instance (SupportedPrim (cop ca cb), LinkedRep ca sa, LinkedRep cb sb) => \ - SubstituteSym (op sa sb) where \ - substituteSym sym v (cons t) = cons $ substTerm sym (underlyingTerm v) t - -#if 1 -SUBSTITUTE_SYM_SIMPLE(SymBool) -SUBSTITUTE_SYM_SIMPLE(SymInteger) -SUBSTITUTE_SYM_BV(SymIntN) -SUBSTITUTE_SYM_BV(SymWordN) -SUBSTITUTE_SYM_FUN((=->), (=~>), SymTabularFun) -SUBSTITUTE_SYM_FUN((-->), (-~>), SymGeneralFun) -SUBSTITUTE_SYM_SIMPLE(SymFPRoundingMode) -#endif - -instance (ValidFP eb sb) => SubstituteSym (SymFP eb sb) where - substituteSym sym v (SymFP t) = SymFP $ substTerm sym (underlyingTerm v) t - --- | Auxiliary class for 'SubstituteSym' instance derivation -class SubstituteSym' a where - -- | Auxiliary function for 'substituteSym' derivation - substituteSym' :: (LinkedRep cb sb) => TypedSymbol cb -> sb -> a c -> a c - -instance - ( Generic a, - SubstituteSym' (Rep a) - ) => - SubstituteSym (Default a) - where - substituteSym sym val = Default . to . substituteSym' sym val . from . unDefault - -instance SubstituteSym' U1 where - substituteSym' _ _ = id - -instance SubstituteSym' V1 where - substituteSym' _ _ = id - -instance (SubstituteSym c) => SubstituteSym' (K1 i c) where - substituteSym' sym val (K1 v) = K1 $ substituteSym sym val v - -instance (SubstituteSym' a) => SubstituteSym' (M1 i c a) where - substituteSym' sym val (M1 v) = M1 $ substituteSym' sym val v - -instance (SubstituteSym' a, SubstituteSym' b) => SubstituteSym' (a :+: b) where - substituteSym' sym val (L1 l) = L1 $ substituteSym' sym val l - substituteSym' sym val (R1 r) = R1 $ substituteSym' sym val r - -instance (SubstituteSym' a, SubstituteSym' b) => SubstituteSym' (a :*: b) where - substituteSym' sym val (a :*: b) = substituteSym' sym val a :*: substituteSym' sym val b diff --git a/src/Grisette/Internal/Core/Data/Class/SymEq.hs b/src/Grisette/Internal/Core/Data/Class/SymEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SymEq.hs @@ -0,0 +1,536 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.SymEq +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SymEq + ( -- * Symbolic equality + SymEq (..), + SymEq1 (..), + symEq1, + SymEq2 (..), + symEq2, + + -- * Generic 'SymEq' + SymEqArgs (..), + GSymEq (..), + genericSymEq, + genericLiftSymEq, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + Generic (Rep, from), + Generic1 (Rep1, from1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&))) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.SymPrim.Prim.Term (pevalEqTerm) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Symbolic equality. Note that we can't use Haskell's 'Eq' class since +-- symbolic comparison won't necessarily return a concrete 'Bool' value. +-- +-- >>> let a = 1 :: SymInteger +-- >>> let b = 2 :: SymInteger +-- >>> a .== b +-- false +-- >>> a ./= b +-- true +-- +-- >>> let a = "a" :: SymInteger +-- >>> let b = "b" :: SymInteger +-- >>> a ./= b +-- (! (= a b)) +-- >>> a ./= b +-- (! (= a b)) +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SymEq via (Default X) +class SymEq a where + (.==) :: a -> a -> SymBool + a .== b = symNot $ a ./= b + {-# INLINE (.==) #-} + infix 4 .== + + (./=) :: a -> a -> SymBool + a ./= b = symNot $ a .== b + {-# INLINE (./=) #-} + infix 4 ./= + {-# MINIMAL (.==) | (./=) #-} + +-- | Lifting of the 'SymEq' class to unary type constructors. +-- +-- Any instance should be subject to the following law that canonicity is +-- preserved: +-- +-- @liftSymEq (.==)@ should be equivalent to @(.==)@, under the symbolic +-- semantics. +-- +-- This class therefore represents the generalization of 'SymEq' by decomposing +-- its main method into a canonical lifting on a canonical inner method, so that +-- the lifting can be reused for other arguments than the canonical one. +class (forall a. (SymEq a) => SymEq (f a)) => SymEq1 f where + -- | Lift a symbolic equality test through the type constructor. + -- + -- The function will usually be applied to an symbolic equality function, but + -- the more general type ensures that the implementation uses it to compare + -- elements of the first container with elements of the second. + liftSymEq :: (a -> b -> SymBool) -> f a -> f b -> SymBool + +-- | Lift the standard @('.==')@ function through the type constructor. +symEq1 :: (SymEq a, SymEq1 f) => f a -> f a -> SymBool +symEq1 = liftSymEq (.==) + +-- | Lifting of the 'SymEq' class to binary type constructors. +class (forall a. (SymEq a) => SymEq1 (f a)) => SymEq2 f where + -- | Lift symbolic equality tests through the type constructor. + -- + -- The function will usually be applied to an symbolic equality function, but + -- the more general type ensures that the implementation uses it to compare + -- elements of the first container with elements of the second. + liftSymEq2 :: + (a -> b -> SymBool) -> + (c -> d -> SymBool) -> + f a c -> + f b d -> + SymBool + +-- | Lift the standard @('.==')@ function through the type constructor. +symEq2 :: (SymEq a, SymEq b, SymEq2 f) => f a b -> f a b -> SymBool +symEq2 = liftSymEq2 (.==) (.==) + +-- Derivations + +-- | The arguments to the generic equality function. +data family SymEqArgs arity a b :: Type + +data instance SymEqArgs Arity0 _ _ = SymEqArgs0 + +newtype instance SymEqArgs Arity1 a b = SymEqArgs1 (a -> b -> SymBool) + +-- | The class of types that can be generically compared for symbolic equality. +class GSymEq arity f where + gsymEq :: SymEqArgs arity a b -> f a -> f b -> SymBool + +instance GSymEq arity V1 where + gsymEq _ _ _ = con True + {-# INLINE gsymEq #-} + +instance GSymEq arity U1 where + gsymEq _ _ _ = con True + {-# INLINE gsymEq #-} + +instance (GSymEq arity a, GSymEq arity b) => GSymEq arity (a :*: b) where + gsymEq args (a1 :*: b1) (a2 :*: b2) = gsymEq args a1 a2 .&& gsymEq args b1 b2 + {-# INLINE gsymEq #-} + +instance (GSymEq arity a, GSymEq arity b) => GSymEq arity (a :+: b) where + gsymEq args (L1 a1) (L1 a2) = gsymEq args a1 a2 + gsymEq args (R1 b1) (R1 b2) = gsymEq args b1 b2 + gsymEq _ _ _ = con False + {-# INLINE gsymEq #-} + +instance (GSymEq arity a) => GSymEq arity (M1 i c a) where + gsymEq args (M1 a1) (M1 a2) = gsymEq args a1 a2 + {-# INLINE gsymEq #-} + +instance (SymEq a) => GSymEq arity (K1 i a) where + gsymEq _ (K1 a) (K1 b) = a .== b + {-# INLINE gsymEq #-} + +instance GSymEq Arity1 Par1 where + gsymEq (SymEqArgs1 e) (Par1 a) (Par1 b) = e a b + {-# INLINE gsymEq #-} + +instance (SymEq1 f) => GSymEq Arity1 (Rec1 f) where + gsymEq (SymEqArgs1 e) (Rec1 a) (Rec1 b) = liftSymEq e a b + {-# INLINE gsymEq #-} + +instance (SymEq1 f, GSymEq Arity1 g) => GSymEq Arity1 (f :.: g) where + gsymEq targs (Comp1 a) (Comp1 b) = liftSymEq (gsymEq targs) a b + {-# INLINE gsymEq #-} + +instance (Generic a, GSymEq Arity0 (Rep a)) => SymEq (Default a) where + Default l .== Default r = genericSymEq l r + {-# INLINE (.==) #-} + +-- | Generic @('.==')@ function. +genericSymEq :: (Generic a, GSymEq Arity0 (Rep a)) => a -> a -> SymBool +genericSymEq l r = gsymEq SymEqArgs0 (from l) (from r) +{-# INLINE genericSymEq #-} + +instance (Generic1 f, GSymEq Arity1 (Rep1 f), SymEq a) => SymEq (Default1 f a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance (Generic1 f, GSymEq Arity1 (Rep1 f)) => SymEq1 (Default1 f) where + liftSymEq f (Default1 l) (Default1 r) = genericLiftSymEq f l r + {-# INLINE liftSymEq #-} + +-- | Generic 'liftSymEq' function. +genericLiftSymEq :: + (Generic1 f, GSymEq Arity1 (Rep1 f)) => + (a -> b -> SymBool) -> + f a -> + f b -> + SymBool +genericLiftSymEq f l r = gsymEq (SymEqArgs1 f) (from1 l) (from1 r) +{-# INLINE genericLiftSymEq #-} + +#define CONCRETE_SEQ(type) \ +instance SymEq type where \ + l .== r = con $ l == r; \ + {-# INLINE (.==) #-} + +#define CONCRETE_SEQ_BV(type) \ +instance (KnownNat n, 1 <= n) => SymEq (type n) where \ + l .== r = con $ l == r; \ + {-# INLINE (.==) #-} + +#if 1 +CONCRETE_SEQ(Bool) +CONCRETE_SEQ(Integer) +CONCRETE_SEQ(Char) +CONCRETE_SEQ(Int) +CONCRETE_SEQ(Int8) +CONCRETE_SEQ(Int16) +CONCRETE_SEQ(Int32) +CONCRETE_SEQ(Int64) +CONCRETE_SEQ(Word) +CONCRETE_SEQ(Word8) +CONCRETE_SEQ(Word16) +CONCRETE_SEQ(Word32) +CONCRETE_SEQ(Word64) +CONCRETE_SEQ(Float) +CONCRETE_SEQ(Double) +CONCRETE_SEQ(B.ByteString) +CONCRETE_SEQ(T.Text) +CONCRETE_SEQ(FPRoundingMode) +CONCRETE_SEQ(Monoid.All) +CONCRETE_SEQ(Monoid.Any) +CONCRETE_SEQ(Ordering) +CONCRETE_SEQ_BV(WordN) +CONCRETE_SEQ_BV(IntN) +#endif + +instance (ValidFP eb sb) => SymEq (FP eb sb) where + l .== r = con $ l == r + {-# INLINE (.==) #-} + +-- Symbolic types +#define SEQ_SIMPLE(symtype) \ +instance SymEq symtype where \ + (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r; \ + {-# INLINE (.==) #-} + +#define SEQ_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SymEq (symtype n) where \ + (symtype l) .== (symtype r) = SymBool $ pevalEqTerm l r; \ + {-# INLINE (.==) #-} + +#if 1 +SEQ_SIMPLE(SymBool) +SEQ_SIMPLE(SymInteger) +SEQ_SIMPLE(SymFPRoundingMode) +SEQ_BV(SymIntN) +SEQ_BV(SymWordN) +#endif + +instance (ValidFP eb sb) => SymEq (SymFP eb sb) where + (SymFP l) .== (SymFP r) = SymBool $ pevalEqTerm l r + {-# INLINE (.==) #-} + +-- Instances +deriveBuiltins + (ViaDefault ''SymEq) + [''SymEq] + [ ''[], + ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] +deriveBuiltins + (ViaDefault1 ''SymEq1) + [''SymEq, ''SymEq1] + [ ''[], + ''Maybe, + ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +-- ExceptT +instance (SymEq1 m, SymEq e, SymEq a) => SymEq (ExceptT e m a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance (SymEq1 m, SymEq e) => SymEq1 (ExceptT e m) where + liftSymEq f (ExceptT l) (ExceptT r) = liftSymEq (liftSymEq f) l r + {-# INLINE liftSymEq #-} + +-- MaybeT +instance (SymEq1 m, SymEq a) => SymEq (MaybeT m a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance (SymEq1 m) => SymEq1 (MaybeT m) where + liftSymEq f (MaybeT l) (MaybeT r) = liftSymEq (liftSymEq f) l r + {-# INLINE liftSymEq #-} + +-- Writer +instance (SymEq1 m, SymEq w, SymEq a) => SymEq (WriterLazy.WriterT w m a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance (SymEq1 m, SymEq w) => SymEq1 (WriterLazy.WriterT w m) where + liftSymEq f (WriterLazy.WriterT l) (WriterLazy.WriterT r) = + liftSymEq (liftSymEq2 f (.==)) l r + {-# INLINE liftSymEq #-} + +instance (SymEq1 m, SymEq w, SymEq a) => SymEq (WriterStrict.WriterT w m a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance (SymEq1 m, SymEq w) => SymEq1 (WriterStrict.WriterT w m) where + liftSymEq f (WriterStrict.WriterT l) (WriterStrict.WriterT r) = + liftSymEq (liftSymEq2 f (.==)) l r + {-# INLINE liftSymEq #-} + +-- IdentityT +instance (SymEq1 m, SymEq a) => SymEq (IdentityT m a) where + (.==) = symEq1 + {-# INLINE (.==) #-} + +instance (SymEq1 m) => SymEq1 (IdentityT m) where + liftSymEq f (IdentityT l) (IdentityT r) = liftSymEq f l r + {-# INLINE liftSymEq #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (SymEq (l a), SymEq (r a)) => SymEq (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (SymEq1 l, SymEq1 r) => SymEq1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (SymEq (l a), SymEq (r a)) => SymEq (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (SymEq1 l, SymEq1 r) => SymEq1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (SymEq (f (g a))) => SymEq (Compose f g a) + +instance (SymEq1 f, SymEq1 g) => SymEq1 (Compose f g) where + liftSymEq f (Compose l) (Compose r) = liftSymEq (liftSymEq f) l r + +-- Const +deriving via (Default (Const a b)) instance (SymEq a) => SymEq (Const a b) + +deriving via (Default1 (Const a)) instance (SymEq a) => SymEq1 (Const a) + +-- Alt +deriving via (Default (Alt f a)) instance (SymEq (f a)) => SymEq (Alt f a) + +deriving via (Default1 (Alt f)) instance (SymEq1 f) => SymEq1 (Alt f) + +-- Ap +deriving via (Default (Ap f a)) instance (SymEq (f a)) => SymEq (Ap f a) + +deriving via (Default1 (Ap f)) instance (SymEq1 f) => SymEq1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance SymEq (U1 p) + +deriving via (Default (V1 p)) instance SymEq (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (SymEq c) => SymEq (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (SymEq (f p)) => SymEq (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (SymEq (f p), SymEq (g p)) => SymEq ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (SymEq (f p), SymEq (g p)) => SymEq ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (SymEq p) => SymEq (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (SymEq (f p)) => SymEq (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (SymEq (f (g p))) => SymEq ((f :.: g) p) + +instance SymEq2 Either where + liftSymEq2 f _ (Left l) (Left r) = f l r + liftSymEq2 _ g (Right l) (Right r) = g l r + liftSymEq2 _ _ _ _ = con False + {-# INLINE liftSymEq2 #-} + +instance SymEq2 (,) where + liftSymEq2 f g (l1, l2) (r1, r2) = f l1 r1 .&& g l2 r2 + {-# INLINE liftSymEq2 #-} + +instance (SymEq a) => SymEq2 ((,,) a) where + liftSymEq2 f g (l1, l2, l3) (r1, r2, r3) = l1 .== r1 .&& f l2 r2 .&& g l3 r3 + {-# INLINE liftSymEq2 #-} + +instance (SymEq a, SymEq b) => SymEq2 ((,,,) a b) where + liftSymEq2 f g (l1, l2, l3, l4) (r1, r2, r3, r4) = + l1 .== r1 .&& l2 .== r2 .&& f l3 r3 .&& g l4 r4 + {-# INLINE liftSymEq2 #-} diff --git a/src/Grisette/Internal/Core/Data/Class/SymOrd.hs b/src/Grisette/Internal/Core/Data/Class/SymOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/Class/SymOrd.hs @@ -0,0 +1,807 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Internal.Core.Data.Class.SymOrd +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.Class.SymOrd + ( -- * Symbolic total order relation + SymOrd (..), + SymOrd1 (..), + symCompare1, + SymOrd2 (..), + symCompare2, + + -- * Min and max + symMax, + symMin, + mrgMax, + mrgMin, + + -- * Generic 'SymOrd' + SymOrdArgs (..), + GSymOrd (..), + genericSymCompare, + genericLiftSymCompare, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down (Down)) +import qualified Data.Text as T +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.TypeLits (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default), + Default1 (Default1), + Generic (Rep, from), + Generic1 (Rep1, from1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1, + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp, symIte) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (symNot, (.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( simpleMerge, + ) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SymBranching, + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.SymEq (GSymEq, SymEq ((.==)), SymEq1, SymEq2) +import Grisette.Internal.Core.Data.Class.TryMerge + ( mrgSingle, + tryMerge, + ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.SymPrim.Prim.Term + ( PEvalOrdTerm + ( pevalLeOrdTerm, + pevalLtOrdTerm + ), + pevalGeOrdTerm, + pevalGtOrdTerm, + ) +import Grisette.Internal.SymPrim.SymBV + ( SymIntN (SymIntN), + SymWordN (SymWordN), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool (SymBool)) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (SymFP), + SymFPRoundingMode (SymFPRoundingMode), + ) +import Grisette.Internal.SymPrim.SymInteger (SymInteger (SymInteger)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) + +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> :set -XDataKinds +-- >>> :set -XBinaryLiterals +-- >>> :set -XFlexibleContexts +-- >>> :set -XFlexibleInstances +-- >>> :set -XFunctionalDependencies + +-- | Symbolic total order. Note that we can't use Haskell's 'Ord' class since +-- symbolic comparison won't necessarily return a concrete 'Bool' or 'Ordering' +-- value. +-- +-- >>> let a = 1 :: SymInteger +-- >>> let b = 2 :: SymInteger +-- >>> a .< b +-- true +-- >>> a .> b +-- false +-- +-- >>> let a = "a" :: SymInteger +-- >>> let b = "b" :: SymInteger +-- >>> a .< b +-- (< a b) +-- >>> a .<= b +-- (<= a b) +-- >>> a .> b +-- (< b a) +-- >>> a .>= b +-- (<= b a) +-- +-- For `symCompare`, `Ordering` is not a solvable type, and the result would +-- be wrapped in a union-like monad. See +-- `Grisette.Core.Control.Monad.Union` and `Grisette.Core.PlainUnion` for more +-- information. +-- +-- >>> a `symCompare` b :: Union Ordering +-- {If (< a b) LT (If (= a b) EQ GT)} +-- +-- __Note:__ This type class can be derived for algebraic data types. +-- You may need the @DerivingVia@ and @DerivingStrategies@ extensions. +-- +-- > data X = ... deriving Generic deriving SymOrd via (Default X) +class (SymEq a) => SymOrd a where + (.<) :: a -> a -> SymBool + infix 4 .< + (.<=) :: a -> a -> SymBool + infix 4 .<= + (.>) :: a -> a -> SymBool + infix 4 .> + (.>=) :: a -> a -> SymBool + infix 4 .>= + x .< y = + simpleMerge $ + symCompare x y >>= \case + LT -> con True + EQ -> con False + GT -> con False + {-# INLINE (.<) #-} + x .<= y = symNot (x .> y) + {-# INLINE (.<=) #-} + x .> y = y .< x + {-# INLINE (.>) #-} + x .>= y = y .<= x + {-# INLINE (.>=) #-} + symCompare :: a -> a -> Union Ordering + symCompare l r = + mrgIf + (l .< r) + (mrgSingle LT) + (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) + {-# INLINE symCompare #-} + {-# MINIMAL (.<) | symCompare #-} + +-- | Lifting of the 'SymOrd' class to unary type constructors. +-- +-- Any instance should be subject to the following law that canonicity is +-- preserved: +-- +-- @liftSymCompare symCompare@ should be equivalent to @symCompare@, under the +-- symbolic semantics. +-- +-- This class therefore represents the generalization of 'SymOrd' by decomposing +-- its main method into a canonical lifting on a canonical inner method, so that +-- the lifting can be reused for other arguments than the canonical one. +class (SymEq1 f, forall a. (SymOrd a) => SymOrd (f a)) => SymOrd1 f where + -- | Lift a 'symCompare' function through the type constructor. + -- + -- The function will usually be applied to an symbolic comparison function, + -- but the more general type ensures that the implementation uses it to + -- compare elements of the first container with elements of the second. + liftSymCompare :: (a -> b -> Union Ordering) -> f a -> f b -> Union Ordering + +-- | Lift the standard 'symCompare' function to binary type constructors. +symCompare1 :: (SymOrd1 f, SymOrd a) => f a -> f a -> Union Ordering +symCompare1 = liftSymCompare symCompare +{-# INLINE symCompare1 #-} + +-- | Lifting of the 'SymOrd' class to binary type constructors. +class (SymEq2 f, forall a. (SymOrd a) => SymOrd1 (f a)) => SymOrd2 f where + -- | Lift a 'symCompare' function through the type constructor. + -- + -- The function will usually be applied to an symbolic comparison function, + -- but the more general type ensures that the implementation uses it to + -- compare elements of the first container with elements of the second. + liftSymCompare2 :: + (a -> b -> Union Ordering) -> + (c -> d -> Union Ordering) -> + f a c -> + f b d -> + Union Ordering + +-- | Lift the standard 'symCompare' function through the type constructors. +symCompare2 :: (SymOrd2 f, SymOrd a, SymOrd b) => f a b -> f a b -> Union Ordering +symCompare2 = liftSymCompare2 symCompare symCompare +{-# INLINE symCompare2 #-} + +-- | Symbolic maximum. +symMax :: (SymOrd a, ITEOp a) => a -> a -> a +symMax x y = symIte (x .>= y) x y +{-# INLINE symMax #-} + +-- | Symbolic minimum. +symMin :: (SymOrd a, ITEOp a) => a -> a -> a +symMin x y = symIte (x .>= y) y x +{-# INLINE symMin #-} + +-- | Symbolic maximum, with a union-like monad. +mrgMax :: + (SymOrd a, Mergeable a, SymBranching m, Applicative m) => + a -> + a -> + m a +mrgMax x y = mrgIf (x .>= y) (pure x) (pure y) +{-# INLINE mrgMax #-} + +-- | Symbolic minimum, with a union-like monad. +mrgMin :: + (SymOrd a, Mergeable a, SymBranching m, Applicative m) => + a -> + a -> + m a +mrgMin x y = mrgIf (x .>= y) (pure y) (pure x) +{-# INLINE mrgMin #-} + +-- Derivations + +-- | The arguments to the generic comparison function. +data family SymOrdArgs arity a b :: Type + +data instance SymOrdArgs Arity0 _ _ = SymOrdArgs0 + +newtype instance SymOrdArgs Arity1 a b + = SymOrdArgs1 (a -> b -> Union Ordering) + +-- | The class of types that can be generically symbolically compared. +class GSymOrd arity f where + gsymCompare :: SymOrdArgs arity a b -> f a -> f b -> Union Ordering + +instance GSymOrd arity V1 where + gsymCompare _ _ _ = mrgSingle EQ + {-# INLINE gsymCompare #-} + +instance GSymOrd arity U1 where + gsymCompare _ _ _ = mrgSingle EQ + {-# INLINE gsymCompare #-} + +instance + (GSymOrd arity a, GSymOrd arity b) => + GSymOrd arity (a :*: b) + where + gsymCompare args (a1 :*: b1) (a2 :*: b2) = do + l <- gsymCompare args a1 a2 + case l of + EQ -> gsymCompare args b1 b2 + _ -> mrgSingle l + {-# INLINE gsymCompare #-} + +instance + (GSymOrd arity a, GSymOrd arity b) => + GSymOrd arity (a :+: b) + where + gsymCompare args (L1 a) (L1 b) = gsymCompare args a b + gsymCompare _ (L1 _) (R1 _) = mrgSingle LT + gsymCompare args (R1 a) (R1 b) = gsymCompare args a b + gsymCompare _ (R1 _) (L1 _) = mrgSingle GT + {-# INLINE gsymCompare #-} + +instance (GSymOrd arity a) => GSymOrd arity (M1 i c a) where + gsymCompare args (M1 a) (M1 b) = gsymCompare args a b + {-# INLINE gsymCompare #-} + +instance (SymOrd a) => GSymOrd arity (K1 i a) where + gsymCompare _ (K1 a) (K1 b) = a `symCompare` b + {-# INLINE gsymCompare #-} + +instance GSymOrd Arity1 Par1 where + gsymCompare (SymOrdArgs1 c) (Par1 a) (Par1 b) = c a b + {-# INLINE gsymCompare #-} + +instance (SymOrd1 f) => GSymOrd Arity1 (Rec1 f) where + gsymCompare (SymOrdArgs1 c) (Rec1 a) (Rec1 b) = liftSymCompare c a b + {-# INLINE gsymCompare #-} + +instance (SymOrd1 f, GSymOrd Arity1 g) => GSymOrd Arity1 (f :.: g) where + gsymCompare targs (Comp1 a) (Comp1 b) = liftSymCompare (gsymCompare targs) a b + {-# INLINE gsymCompare #-} + +instance + (Generic a, GSymOrd Arity0 (Rep a), GSymEq Arity0 (Rep a)) => + SymOrd (Default a) + where + symCompare (Default l) (Default r) = genericSymCompare l r + {-# INLINE symCompare #-} + +-- | Generic 'symCompare' function. +genericSymCompare :: (Generic a, GSymOrd Arity0 (Rep a)) => a -> a -> Union Ordering +genericSymCompare l r = gsymCompare SymOrdArgs0 (from l) (from r) +{-# INLINE genericSymCompare #-} + +instance + (Generic1 f, GSymOrd Arity1 (Rep1 f), GSymEq Arity1 (Rep1 f), SymOrd a) => + SymOrd (Default1 f a) + where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance + (Generic1 f, GSymOrd Arity1 (Rep1 f), GSymEq Arity1 (Rep1 f)) => + SymOrd1 (Default1 f) + where + liftSymCompare c (Default1 l) (Default1 r) = genericLiftSymCompare c l r + {-# INLINE liftSymCompare #-} + +-- | Generic 'liftSymCompare' function. +genericLiftSymCompare :: + (Generic1 f, GSymOrd Arity1 (Rep1 f)) => + (a -> b -> Union Ordering) -> + f a -> + f b -> + Union Ordering +genericLiftSymCompare c l r = gsymCompare (SymOrdArgs1 c) (from1 l) (from1 r) +{-# INLINE genericLiftSymCompare #-} + +#define CONCRETE_SORD(type) \ +instance SymOrd type where \ + l .<= r = con $ l <= r; \ + l .< r = con $ l < r; \ + l .>= r = con $ l >= r; \ + l .> r = con $ l > r; \ + symCompare l r = mrgSingle $ compare l r; \ + {-# INLINE (.<=) #-}; \ + {-# INLINE (.<) #-}; \ + {-# INLINE (.>=) #-}; \ + {-# INLINE (.>) #-}; \ + {-# INLINE symCompare #-} + +#define CONCRETE_SORD_BV(type) \ +instance (KnownNat n, 1 <= n) => SymOrd (type n) where \ + l .<= r = con $ l <= r; \ + l .< r = con $ l < r; \ + l .>= r = con $ l >= r; \ + l .> r = con $ l > r; \ + symCompare l r = mrgSingle $ compare l r; \ + {-# INLINE (.<=) #-}; \ + {-# INLINE (.<) #-}; \ + {-# INLINE (.>=) #-}; \ + {-# INLINE (.>) #-}; \ + {-# INLINE symCompare #-} + +#if 1 +CONCRETE_SORD(Bool) +CONCRETE_SORD(Integer) +CONCRETE_SORD(Char) +CONCRETE_SORD(Int) +CONCRETE_SORD(Int8) +CONCRETE_SORD(Int16) +CONCRETE_SORD(Int32) +CONCRETE_SORD(Int64) +CONCRETE_SORD(Word) +CONCRETE_SORD(Word8) +CONCRETE_SORD(Word16) +CONCRETE_SORD(Word32) +CONCRETE_SORD(Word64) +CONCRETE_SORD(Float) +CONCRETE_SORD(Double) +CONCRETE_SORD(B.ByteString) +CONCRETE_SORD(T.Text) +CONCRETE_SORD(FPRoundingMode) +CONCRETE_SORD(Monoid.All) +CONCRETE_SORD(Monoid.Any) +CONCRETE_SORD(Ordering) +CONCRETE_SORD_BV(WordN) +CONCRETE_SORD_BV(IntN) +#endif + +instance (ValidFP eb sb) => SymOrd (FP eb sb) where + l .<= r = con $ l <= r + {-# INLINE (.<=) #-} + l .< r = con $ l < r + {-# INLINE (.<) #-} + l .>= r = con $ l >= r + {-# INLINE (.>=) #-} + l .> r = con $ l > r + {-# INLINE (.>) #-} + +-- SymOrd +#define SORD_SIMPLE(symtype) \ +instance SymOrd symtype where \ + (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ + (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ + (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ + (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ + a `symCompare` b = mrgIf \ + (a .< b) \ + (mrgSingle LT) \ + (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)); \ + {-# INLINE (.<=) #-}; \ + {-# INLINE (.<) #-}; \ + {-# INLINE (.>=) #-}; \ + {-# INLINE (.>) #-}; \ + {-# INLINE symCompare #-} + +#define SORD_BV(symtype) \ +instance (KnownNat n, 1 <= n) => SymOrd (symtype n) where \ + (symtype a) .<= (symtype b) = SymBool $ pevalLeOrdTerm a b; \ + (symtype a) .< (symtype b) = SymBool $ pevalLtOrdTerm a b; \ + (symtype a) .>= (symtype b) = SymBool $ pevalGeOrdTerm a b; \ + (symtype a) .> (symtype b) = SymBool $ pevalGtOrdTerm a b; \ + a `symCompare` b = mrgIf \ + (a .< b) \ + (mrgSingle LT) \ + (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)); \ + {-# INLINE (.<=) #-}; \ + {-# INLINE (.<) #-}; \ + {-# INLINE (.>=) #-}; \ + {-# INLINE (.>) #-}; \ + {-# INLINE symCompare #-} + +instance (ValidFP eb sb) => SymOrd (SymFP eb sb) where + (SymFP a) .<= (SymFP b) = SymBool $ pevalLeOrdTerm a b + {-# INLINE (.<=) #-} + (SymFP a) .< (SymFP b) = SymBool $ pevalLtOrdTerm a b + {-# INLINE (.<) #-} + (SymFP a) .>= (SymFP b) = SymBool $ pevalGeOrdTerm a b + {-# INLINE (.>=) #-} + (SymFP a) .> (SymFP b) = SymBool $ pevalGtOrdTerm a b + {-# INLINE (.>) #-} + +instance SymOrd SymBool where + l .<= r = symNot l .|| r + {-# INLINE (.<=) #-} + l .< r = symNot l .&& r + {-# INLINE (.<) #-} + l .>= r = l .|| symNot r + {-# INLINE (.>=) #-} + l .> r = l .&& symNot r + {-# INLINE (.>) #-} + symCompare l r = + mrgIf + (symNot l .&& r) + (mrgSingle LT) + (mrgIf (l .== r) (mrgSingle EQ) (mrgSingle GT)) + {-# INLINE symCompare #-} + +#if 1 +SORD_SIMPLE(SymInteger) +SORD_SIMPLE(SymFPRoundingMode) +SORD_BV(SymIntN) +SORD_BV(SymWordN) +#endif + +-- Union +instance (SymOrd a) => SymOrd (Union a) where + x .<= y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 .<= y1 + x .< y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 .< y1 + x .>= y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 .>= y1 + x .> y = simpleMerge $ do + x1 <- x + y1 <- y + mrgSingle $ x1 .> y1 + x `symCompare` y = tryMerge $ do + x1 <- x + y1 <- y + x1 `symCompare` y1 + +instance SymOrd1 Union where + liftSymCompare f x y = tryMerge $ do + x1 <- x + y1 <- y + f x1 y1 + +-- Instances +deriveBuiltins + (ViaDefault ''SymOrd) + [''SymOrd] + [ ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last + ] + +deriveBuiltins + (ViaDefault1 ''SymOrd1) + [''SymOrd, ''SymOrd1] + [ ''Maybe, + ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Identity, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last + ] + +symCompareSingleList :: (SymOrd a) => Bool -> Bool -> [a] -> [a] -> SymBool +symCompareSingleList isLess isStrict = go + where + go [] [] = con (not isStrict) + go (x : xs) (y : ys) = + (if isLess then x .< y else x .> y) .|| (x .== y .&& go xs ys) + go [] _ = if isLess then con True else con False + go _ [] = if isLess then con False else con True + +symLiftCompareList :: + (a -> b -> Union Ordering) -> [a] -> [b] -> Union Ordering +symLiftCompareList _ [] [] = mrgSingle EQ +symLiftCompareList f (x : xs) (y : ys) = do + oxy <- f x y + case oxy of + LT -> mrgSingle LT + EQ -> symLiftCompareList f xs ys + GT -> mrgSingle GT +symLiftCompareList _ [] _ = mrgSingle LT +symLiftCompareList _ _ [] = mrgSingle GT + +-- [] +instance (SymOrd a) => SymOrd [a] where + {-# INLINE (.<=) #-} + {-# INLINE (.<) #-} + {-# INLINE symCompare #-} + {-# INLINE (.>=) #-} + {-# INLINE (.>) #-} + (.<=) = symCompareSingleList True False + (.<) = symCompareSingleList True True + (.>=) = symCompareSingleList False False + (.>) = symCompareSingleList False True + symCompare = symLiftCompareList symCompare + +instance SymOrd1 [] where + liftSymCompare = symLiftCompareList + {-# INLINE liftSymCompare #-} + +-- ExceptT +instance (SymOrd1 m, SymOrd e, SymOrd a) => SymOrd (ExceptT e m a) where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance (SymOrd1 m, SymOrd e) => SymOrd1 (ExceptT e m) where + liftSymCompare f (ExceptT l) (ExceptT r) = + liftSymCompare (liftSymCompare f) l r + {-# INLINE liftSymCompare #-} + +-- MaybeT +instance (SymOrd1 m, SymOrd a) => SymOrd (MaybeT m a) where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance (SymOrd1 m) => SymOrd1 (MaybeT m) where + liftSymCompare f (MaybeT l) (MaybeT r) = liftSymCompare (liftSymCompare f) l r + {-# INLINE liftSymCompare #-} + +-- Writer +instance (SymOrd1 m, SymOrd w, SymOrd a) => SymOrd (WriterLazy.WriterT w m a) where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance (SymOrd1 m, SymOrd w) => SymOrd1 (WriterLazy.WriterT w m) where + liftSymCompare f (WriterLazy.WriterT l) (WriterLazy.WriterT r) = + liftSymCompare (liftSymCompare2 f symCompare) l r + {-# INLINE liftSymCompare #-} + +instance (SymOrd1 m, SymOrd w, SymOrd a) => SymOrd (WriterStrict.WriterT w m a) where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance (SymOrd1 m, SymOrd w) => SymOrd1 (WriterStrict.WriterT w m) where + liftSymCompare f (WriterStrict.WriterT l) (WriterStrict.WriterT r) = + liftSymCompare (liftSymCompare2 f symCompare) l r + {-# INLINE liftSymCompare #-} + +-- IdentityT +instance (SymOrd1 m, SymOrd a) => SymOrd (IdentityT m a) where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance (SymOrd1 m) => SymOrd1 (IdentityT m) where + liftSymCompare f (IdentityT l) (IdentityT r) = liftSymCompare f l r + {-# INLINE liftSymCompare #-} + +-- Product +deriving via + (Default (Product l r a)) + instance + (SymOrd (l a), SymOrd (r a)) => SymOrd (Product l r a) + +deriving via + (Default1 (Product l r)) + instance + (SymOrd1 l, SymOrd1 r) => SymOrd1 (Product l r) + +-- Sum +deriving via + (Default (Sum l r a)) + instance + (SymOrd (l a), SymOrd (r a)) => SymOrd (Sum l r a) + +deriving via + (Default1 (Sum l r)) + instance + (SymOrd1 l, SymOrd1 r) => SymOrd1 (Sum l r) + +-- Compose +deriving via + (Default (Compose f g a)) + instance + (SymOrd (f (g a))) => SymOrd (Compose f g a) + +instance (SymOrd1 f, SymOrd1 g) => SymOrd1 (Compose f g) where + liftSymCompare f (Compose l) (Compose r) = + liftSymCompare (liftSymCompare f) l r + +-- Const +deriving via (Default (Const a b)) instance (SymOrd a) => SymOrd (Const a b) + +deriving via (Default1 (Const a)) instance (SymOrd a) => SymOrd1 (Const a) + +-- Alt +deriving via (Default (Alt f a)) instance (SymOrd (f a)) => SymOrd (Alt f a) + +deriving via (Default1 (Alt f)) instance (SymOrd1 f) => SymOrd1 (Alt f) + +-- Ap +deriving via (Default (Ap f a)) instance (SymOrd (f a)) => SymOrd (Ap f a) + +deriving via (Default1 (Ap f)) instance (SymOrd1 f) => SymOrd1 (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance SymOrd (U1 p) + +deriving via (Default (V1 p)) instance SymOrd (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (SymOrd c) => SymOrd (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (SymOrd (f p)) => SymOrd (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (SymOrd (f p), SymOrd (g p)) => SymOrd ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (SymOrd (f p), SymOrd (g p)) => SymOrd ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (SymOrd p) => SymOrd (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (SymOrd (f p)) => SymOrd (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (SymOrd (f (g p))) => SymOrd ((f :.: g) p) + +-- Down +instance (SymOrd a) => SymOrd (Down a) where + symCompare = symCompare1 + {-# INLINE symCompare #-} + +instance SymOrd1 Down where + liftSymCompare comp (Down l) (Down r) = do + res <- comp l r + case res of + LT -> mrgSingle GT + EQ -> mrgSingle EQ + GT -> mrgSingle LT + {-# INLINE liftSymCompare #-} + +instance SymOrd2 Either where + liftSymCompare2 f _ (Left l) (Left r) = f l r + liftSymCompare2 _ g (Right l) (Right r) = g l r + liftSymCompare2 _ _ (Left _) (Right _) = mrgSingle LT + liftSymCompare2 _ _ (Right _) (Left _) = mrgSingle GT + {-# INLINE liftSymCompare2 #-} + +instance SymOrd2 (,) where + liftSymCompare2 f g (a1, b1) (a2, b2) = do + ma <- f a1 a2 + mb <- g b1 b2 + mrgSingle $ ma <> mb + {-# INLINE liftSymCompare2 #-} + +instance (SymOrd a) => SymOrd2 ((,,) a) where + liftSymCompare2 f g (a1, b1, c1) (a2, b2, c2) = do + ma <- symCompare a1 a2 + mb <- f b1 b2 + mc <- g c1 c2 + mrgSingle $ ma <> mb <> mc + {-# INLINE liftSymCompare2 #-} + +instance (SymOrd a, SymOrd b) => SymOrd2 ((,,,) a b) where + liftSymCompare2 f g (a1, b1, c1, d1) (a2, b2, c2, d2) = do + ma <- symCompare a1 a2 + mb <- symCompare b1 b2 + mc <- f c1 c2 + md <- g d1 d2 + mrgSingle $ ma <> mb <> mc <> md + {-# INLINE liftSymCompare2 #-} diff --git a/src/Grisette/Internal/Core/Data/Class/SymRotate.hs b/src/Grisette/Internal/Core/Data/Class/SymRotate.hs --- a/src/Grisette/Internal/Core/Data/Class/SymRotate.hs +++ b/src/Grisette/Internal/Core/Data/Class/SymRotate.hs @@ -6,6 +6,14 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Grisette.Internal.Core.Data.Class.SymRotate +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Internal.Core.Data.Class.SymRotate ( SymRotate (..), DefaultFiniteBitsSymRotate (..), @@ -33,6 +41,8 @@ | s /= minBound = rotate a (-s) | otherwise = rotate a (-(s + finiteBitSize s)) +-- | A newtype wrapper. Use this to derive `SymRotate` for types that have +-- `FiniteBits` instances. newtype DefaultFiniteBitsSymRotate a = DefaultFiniteBitsSymRotate { unDefaultFiniteBitsSymRotate :: a } diff --git a/src/Grisette/Internal/Core/Data/Class/SymShift.hs b/src/Grisette/Internal/Core/Data/Class/SymShift.hs --- a/src/Grisette/Internal/Core/Data/Class/SymShift.hs +++ b/src/Grisette/Internal/Core/Data/Class/SymShift.hs @@ -6,6 +6,14 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Grisette.Internal.Core.Data.Class.SymShift +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Internal.Core.Data.Class.SymShift ( SymShift (..), DefaultFiniteBitsSymShift (..), @@ -40,6 +48,8 @@ | s <= -finiteBitSize a = 0 | otherwise = symShift a (-s) +-- | A newtype wrapper. Use this to derive `SymShift` for types that have +-- `FiniteBits` instances. newtype DefaultFiniteBitsSymShift a = DefaultFiniteBitsSymShift { unDefaultFiniteBitsSymShift :: a } diff --git a/src/Grisette/Internal/Core/Data/Class/ToCon.hs b/src/Grisette/Internal/Core/Data/Class/ToCon.hs --- a/src/Grisette/Internal/Core/Data/Class/ToCon.hs +++ b/src/Grisette/Internal/Core/Data/Class/ToCon.hs @@ -7,10 +7,12 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} @@ -25,6 +27,16 @@ module Grisette.Internal.Core.Data.Class.ToCon ( -- * Converting to concrete values ToCon (..), + ToCon1 (..), + toCon1, + ToCon2 (..), + toCon2, + + -- * Generic 'ToCon' + ToConArgs (..), + GToCon (..), + genericToCon, + genericLiftToCon, ) where @@ -37,17 +49,42 @@ import qualified Control.Monad.Writer.Lazy as WriterLazy import qualified Control.Monad.Writer.Strict as WriterStrict import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) import Data.Functor.Sum (Sum) import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics (Generic (Rep, from, to), K1 (K1), M1 (M1), U1, V1, type (:*:) ((:*:)), type (:+:) (L1, R1)) +import GHC.Generics + ( Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), + K1 (K1), + M1 (M1), + Par1 (Par1), + Rec1 (Rec1), + U1 (U1), + V1, + (:.:) (Comp1), + type (:*:) ((:*:)), + type (:+:) (L1, R1), + ) import GHC.TypeNats (KnownNat, type (<=)) -import Generics.Deriving (Default (Default)) +import Generics.Deriving (Default (Default), Default1 (Default1)) import Generics.Deriving.Instances () -import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast)) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (conView), pattern Con) +import Grisette.Internal.Core.Data.Class.Solvable + ( Solvable (conView), + pattern Con, + ) import Grisette.Internal.SymPrim.BV ( IntN (IntN), WordN (WordN), @@ -64,11 +101,21 @@ SymWordN, ) import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP (SymFP, SymFP32, SymFP64, SymFPRoundingMode) +import Grisette.Internal.SymPrim.SymFP + ( SymFP, + SymFP32, + SymFP64, + SymFPRoundingMode, + ) import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) import Grisette.Internal.SymPrim.SymInteger (SymInteger) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) -- $setup -- >>> import Grisette.Core @@ -94,6 +141,129 @@ -- Nothing toCon :: a -> Maybe b +instance {-# INCOHERENT #-} ToCon v v where + toCon = Just + +-- | Lifting of 'ToCon' to unary type constructors. +class (forall a b. (ToCon a b) => ToCon (f1 a) (f2 b)) => ToCon1 f1 f2 where + -- | Lift a conversion to concrete function to unary type constructors. + liftToCon :: (a -> Maybe b) -> f1 a -> Maybe (f2 b) + +-- | Lift the standard 'toCon' to unary type constructors. +toCon1 :: (ToCon1 f1 f2, ToCon a b) => f1 a -> Maybe (f2 b) +toCon1 = liftToCon toCon +{-# INLINE toCon1 #-} + +-- | Lifting of 'ToCon' to binary type constructors. +class (forall a b. (ToCon a b) => ToCon1 (f1 a) (f2 b)) => ToCon2 f1 f2 where + -- | Lift conversion to concrete functions to binary type constructors. + liftToCon2 :: (a -> Maybe b) -> (c -> Maybe d) -> f1 a c -> Maybe (f2 b d) + +-- | Lift the standard 'toCon' to binary type constructors. +toCon2 :: (ToCon2 f1 f2, ToCon a b, ToCon c d) => f1 a c -> Maybe (f2 b d) +toCon2 = liftToCon2 toCon toCon +{-# INLINE toCon2 #-} + +-- Derivations + +-- | The arguments to the generic 'toCon' function. +data family ToConArgs arity a b :: Type + +data instance ToConArgs Arity0 _ _ = ToConArgs0 + +newtype instance ToConArgs Arity1 a b + = ToConArgs1 (a -> Maybe b) + +-- | The class of types that can be generically converted to concrete values. +class GToCon arity f1 f2 where + gtoCon :: ToConArgs arity a b -> f1 a -> Maybe (f2 b) + +instance GToCon arity V1 V1 where + gtoCon _ _ = error "Impossible" + {-# INLINE gtoCon #-} + +instance GToCon arity U1 U1 where + gtoCon _ _ = Just U1 + {-# INLINE gtoCon #-} + +instance + (GToCon arity a b, GToCon arity c d) => + GToCon arity (a :*: c) (b :*: d) + where + gtoCon args (a :*: c) = do + a' <- gtoCon args a + c' <- gtoCon args c + return $ a' :*: c' + {-# INLINE gtoCon #-} + +instance + (GToCon arity a b, GToCon arity c d) => + GToCon arity (a :+: c) (b :+: d) + where + gtoCon args (L1 a) = L1 <$> gtoCon args a + gtoCon args (R1 a) = R1 <$> gtoCon args a + {-# INLINE gtoCon #-} + +instance (GToCon arity a b) => GToCon arity (M1 i c1 a) (M1 i c2 b) where + gtoCon args (M1 a) = M1 <$> gtoCon args a + {-# INLINE gtoCon #-} + +instance (ToCon a b) => GToCon arity (K1 i a) (K1 i b) where + gtoCon _ (K1 a) = K1 <$> toCon a + {-# INLINE gtoCon #-} + +instance GToCon Arity1 Par1 Par1 where + gtoCon (ToConArgs1 f) (Par1 a) = Par1 <$> f a + {-# INLINE gtoCon #-} + +instance (ToCon1 f1 f2) => GToCon Arity1 (Rec1 f1) (Rec1 f2) where + gtoCon (ToConArgs1 f) (Rec1 a) = Rec1 <$> liftToCon f a + {-# INLINE gtoCon #-} + +instance + (ToCon1 f1 f2, GToCon Arity1 g1 g2) => + GToCon Arity1 (f1 :.: g1) (f2 :.: g2) + where + gtoCon targs (Comp1 a) = Comp1 <$> liftToCon (gtoCon targs) a + {-# INLINE gtoCon #-} + +-- | Generic 'toCon' function. +genericToCon :: + (Generic a, Generic b, GToCon Arity0 (Rep a) (Rep b)) => + a -> + Maybe b +genericToCon = fmap to . gtoCon ToConArgs0 . from +{-# INLINE genericToCon #-} + +-- | Generic 'liftToCon' function. +genericLiftToCon :: + (Generic1 f1, Generic1 f2, GToCon Arity1 (Rep1 f1) (Rep1 f2)) => + (a -> Maybe b) -> + f1 a -> + Maybe (f2 b) +genericLiftToCon f = fmap to1 . gtoCon (ToConArgs1 f) . from1 +{-# INLINE genericLiftToCon #-} + +instance + (Generic a, Generic b, GToCon Arity0 (Rep a) (Rep b)) => + ToCon a (Default b) + where + toCon = fmap Default . genericToCon + {-# INLINE toCon #-} + +instance + (Generic1 f1, Generic1 f2, GToCon Arity1 (Rep1 f1) (Rep1 f2), ToCon a b) => + ToCon (f1 a) (Default1 f2 b) + where + toCon = toCon1 + +instance + (Generic1 f1, Generic1 f2, GToCon Arity1 (Rep1 f1) (Rep1 f2)) => + ToCon1 f1 (Default1 f2) + where + liftToCon f = fmap Default1 . genericLiftToCon f + {-# INLINE liftToCon #-} + #define CONCRETE_TOCON(type) \ instance ToCon type type where \ toCon = Just @@ -123,117 +293,14 @@ CONCRETE_TOCON_BV(WordN) CONCRETE_TOCON_BV(IntN) CONCRETE_TOCON(FPRoundingMode) +CONCRETE_TOCON(Monoid.All) +CONCRETE_TOCON(Monoid.Any) +CONCRETE_TOCON(Ordering) #endif instance (ValidFP eb sb) => ToCon (FP eb sb) (FP eb sb) where toCon = Just --- Unit -instance ToCon () () where - toCon = Just - --- Either -deriving via (Default (Either e2 a2)) instance (ToCon e1 e2, ToCon a1 a2) => ToCon (Either e1 a1) (Either e2 a2) - --- Maybe -deriving via (Default (Maybe a2)) instance (ToCon a1 a2) => ToCon (Maybe a1) (Maybe a2) - --- List -deriving via (Default [b]) instance (ToCon a b) => ToCon [a] [b] - --- (,) -deriving via (Default (a2, b2)) instance (ToCon a1 a2, ToCon b1 b2) => ToCon (a1, b1) (a2, b2) - --- (,,) -deriving via (Default (a2, b2, c2)) instance (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2) => ToCon (a1, b1, c1) (a2, b2, c2) - --- (,,,) -deriving via - (Default (a2, b2, c2, d2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2) => ToCon (a1, b1, c1, d1) (a2, b2, c2, d2) - --- (,,,,) -deriving via - (Default (a2, b2, c2, d2, e2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2) => - ToCon (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) - --- (,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2) => - ToCon (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) - --- (,,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2, g2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2, ToCon g1 g2) => - ToCon (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) - --- (,,,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2, g2, h2)) - instance - (ToCon a1 a2, ToCon b1 b2, ToCon c1 c2, ToCon d1 d2, ToCon e1 e2, ToCon f1 f2, ToCon g1 g2, ToCon h1 h2) => - ToCon (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) - --- MaybeT -instance - (ToCon (m1 (Maybe a)) (m2 (Maybe b))) => - ToCon (MaybeT m1 a) (MaybeT m2 b) - where - toCon (MaybeT v) = MaybeT <$> toCon v - --- ExceptT -instance - (ToCon (m1 (Either e1 a)) (m2 (Either e2 b))) => - ToCon (ExceptT e1 m1 a) (ExceptT e2 m2 b) - where - toCon (ExceptT v) = ExceptT <$> toCon v - -instance - (ToCon (m1 (Either e1 a)) (Either e2 b)) => - ToCon (ExceptT e1 m1 a) (Either e2 b) - where - toCon (ExceptT v) = toCon v - --- Sum -deriving via - (Default (Sum f1 g1 a1)) - instance - (ToCon (f a) (f1 a1), ToCon (g a) (g1 a1)) => ToCon (Sum f g a) (Sum f1 g1 a1) - --- WriterT -instance - (ToCon (m1 (a, s1)) (m2 (b, s2))) => - ToCon (WriterLazy.WriterT s1 m1 a) (WriterLazy.WriterT s2 m2 b) - where - toCon (WriterLazy.WriterT v) = WriterLazy.WriterT <$> toCon v - -instance - (ToCon (m1 (a, s1)) (m2 (b, s2))) => - ToCon (WriterStrict.WriterT s1 m1 a) (WriterStrict.WriterT s2 m2 b) - where - toCon (WriterStrict.WriterT v) = WriterStrict.WriterT <$> toCon v - --- Identity -instance (ToCon a b) => ToCon (Identity a) (Identity b) where - toCon (Identity a) = Identity <$> toCon a - -instance ToCon (Identity v) v where - toCon = Just . runIdentity - -instance ToCon v (Identity v) where - toCon = Just . Identity - --- IdentityT -instance (ToCon (m a) (m1 b)) => ToCon (IdentityT m a) (IdentityT m1 b) where - toCon (IdentityT a) = IdentityT <$> toCon a - #define TO_CON_SYMID_SIMPLE(symtype) \ instance ToCon symtype symtype where \ toCon = Just @@ -311,41 +378,283 @@ toCon (Con (fp :: FP64)) = Just $ bitCast fp toCon _ = Nothing +deriveBuiltins + (ViaDefault ''ToCon) + [''ToCon] + [ ''[], + ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +deriveBuiltins + (ViaDefault1 ''ToCon1) + [''ToCon, ''ToCon1] + [ ''[], + ''Maybe, + ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +-- ExceptT +instance + (ToCon1 m1 m2, ToCon e1 e2, ToCon a b) => + ToCon (ExceptT e1 m1 a) (ExceptT e2 m2 b) + where + toCon = toCon1 + {-# INLINE toCon #-} + +instance + (ToCon1 m1 m2, ToCon e1 e2) => + ToCon1 (ExceptT e1 m1) (ExceptT e2 m2) + where + liftToCon f (ExceptT v) = ExceptT <$> liftToCon (liftToCon f) v + {-# INLINE liftToCon #-} + +-- MaybeT +instance + (ToCon1 m1 m2, ToCon a b) => + ToCon (MaybeT m1 a) (MaybeT m2 b) + where + toCon = toCon1 + {-# INLINE toCon #-} + +instance + (ToCon1 m1 m2) => + ToCon1 (MaybeT m1) (MaybeT m2) + where + liftToCon f (MaybeT v) = MaybeT <$> liftToCon (liftToCon f) v + {-# INLINE liftToCon #-} + +-- WriterT +instance + (ToCon1 m1 m2, ToCon a b, ToCon s1 s2) => + ToCon (WriterLazy.WriterT s1 m1 a) (WriterLazy.WriterT s2 m2 b) + where + toCon (WriterLazy.WriterT v) = WriterLazy.WriterT <$> toCon v + +instance + (ToCon1 m1 m2, ToCon s1 s2) => + ToCon1 (WriterLazy.WriterT s1 m1) (WriterLazy.WriterT s2 m2) + where + liftToCon f (WriterLazy.WriterT v) = + WriterLazy.WriterT <$> liftToCon (liftToCon2 f toCon) v + +instance + (ToCon1 m1 m2, ToCon a b, ToCon s1 s2) => + ToCon (WriterStrict.WriterT s1 m1 a) (WriterStrict.WriterT s2 m2 b) + where + toCon (WriterStrict.WriterT v) = WriterStrict.WriterT <$> toCon v + +instance + (ToCon1 m1 m2, ToCon s1 s2) => + ToCon1 (WriterStrict.WriterT s1 m1) (WriterStrict.WriterT s2 m2) + where + liftToCon f (WriterStrict.WriterT v) = + WriterStrict.WriterT <$> liftToCon (liftToCon2 f toCon) v + +-- IdentityT +instance + (ToCon1 m m1, ToCon a b) => + ToCon (IdentityT m a) (IdentityT m1 b) + where + toCon = toCon1 + {-# INLINE toCon #-} + +instance + (ToCon1 m m1) => + ToCon1 (IdentityT m) (IdentityT m1) + where + liftToCon f (IdentityT a) = IdentityT <$> liftToCon f a + {-# INLINE liftToCon #-} + +-- Identity +instance {-# INCOHERENT #-} (ToCon a b) => ToCon (Identity a) (Identity b) where + toCon = toCon1 + +instance {-# INCOHERENT #-} (ToCon a b) => ToCon (Identity a) b where + toCon = toCon . runIdentity + +instance {-# INCOHERENT #-} (ToCon a b) => ToCon a (Identity b) where + toCon = fmap Identity . toCon + +instance ToCon1 Identity Identity where + liftToCon f (Identity a) = Identity <$> f a + +-- Special +instance + (ToCon (m1 (Either e1 a)) (Either e2 b)) => + ToCon (ExceptT e1 m1 a) (Either e2 b) + where + toCon (ExceptT v) = toCon v + +-- Product deriving via - (Default AssertionError) + (Default (Product l r a)) instance - ToCon AssertionError AssertionError + (ToCon (l0 a0) (l a), ToCon (r0 a0) (r a)) => + ToCon (Product l0 r0 a0) (Product l r a) deriving via - (Default VerificationConditions) + (Default1 (Product l r)) instance - ToCon VerificationConditions VerificationConditions + (ToCon1 l0 l, ToCon1 r0 r) => ToCon1 (Product l0 r0) (Product l r) --- Derivation of ToCon for generic types -instance (Generic a, Generic b, ToCon' (Rep a) (Rep b)) => ToCon a (Default b) where - toCon v = fmap (Default . to) $ toCon' $ from v +-- Sum +deriving via + (Default (Sum l r a)) + instance + (ToCon (l0 a0) (l a), ToCon (r0 a0) (r a)) => + ToCon (Sum l0 r0 a0) (Sum l r a) -class ToCon' a b where - toCon' :: a c -> Maybe (b c) +deriving via + (Default1 (Sum l r)) + instance + (ToCon1 l0 l, ToCon1 r0 r) => ToCon1 (Sum l0 r0) (Sum l r) -instance ToCon' U1 U1 where - toCon' = Just +-- Compose +deriving via + (Default (Compose f g a)) + instance + (ToCon (f0 (g0 a0)) (f (g a))) => ToCon (Compose f0 g0 a0) (Compose f g a) -instance ToCon' V1 V1 where - toCon' = Just +instance + (ToCon1 f0 f, ToCon1 g0 g) => + ToCon1 (Compose f0 g0) (Compose f g) + where + liftToCon f (Compose a) = Compose <$> liftToCon (liftToCon f) a + {-# INLINE liftToCon #-} -instance (ToCon a b) => ToCon' (K1 i a) (K1 i b) where - toCon' (K1 a) = K1 <$> toCon a +-- Const +deriving via + (Default (Const a b)) + instance + (ToCon a0 a) => ToCon (Const a0 b0) (Const a b) -instance (ToCon' a b) => ToCon' (M1 i c1 a) (M1 i c2 b) where - toCon' (M1 a) = M1 <$> toCon' a +deriving via + (Default1 (Const a)) + instance + (ToCon a0 a) => ToCon1 (Const a0) (Const a) -instance (ToCon' a1 a2, ToCon' b1 b2) => ToCon' (a1 :+: b1) (a2 :+: b2) where - toCon' (L1 a) = L1 <$> toCon' a - toCon' (R1 a) = R1 <$> toCon' a +-- Alt +deriving via + (Default (Alt f a)) + instance + (ToCon (f0 a0) (f a)) => ToCon (Alt f0 a0) (Alt f a) -instance (ToCon' a1 a2, ToCon' b1 b2) => ToCon' (a1 :*: b1) (a2 :*: b2) where - toCon' (a :*: b) = do - ac <- toCon' a - bc <- toCon' b - return $ ac :*: bc +deriving via + (Default1 (Alt f)) + instance + (ToCon1 f0 f) => ToCon1 (Alt f0) (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (ToCon (f0 a0) (f a)) => ToCon (Ap f0 a0) (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (ToCon1 f0 f) => ToCon1 (Ap f0) (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance ToCon (U1 p0) (U1 p) + +deriving via (Default (V1 p)) instance ToCon (V1 p0) (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (ToCon c0 c) => ToCon (K1 i0 c0 p0) (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (ToCon (f0 p0) (f p)) => ToCon (M1 i0 c0 f0 p0) (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (ToCon (f0 p0) (f p), ToCon (g0 p0) (g p)) => + ToCon ((f0 :+: g0) p0) ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (ToCon (f0 p0) (f p), ToCon (g0 p0) (g p)) => + ToCon ((f0 :*: g0) p0) ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (ToCon p0 p) => ToCon (Par1 p0) (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (ToCon (f0 p0) (f p)) => ToCon (Rec1 f0 p0) (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (ToCon (f0 (g0 p0)) (f (g p))) => ToCon ((f0 :.: g0) p0) ((f :.: g) p) + +-- ToCon2 +instance ToCon2 Either Either where + liftToCon2 f _ (Left a) = Left <$> f a + liftToCon2 _ g (Right b) = Right <$> g b + {-# INLINE liftToCon2 #-} + +instance ToCon2 (,) (,) where + liftToCon2 f g (a, b) = (,) <$> f a <*> g b + {-# INLINE liftToCon2 #-} + +instance (ToCon a b) => ToCon2 ((,,) a) ((,,) b) where + liftToCon2 f g (a, b, c) = (,,) <$> toCon a <*> f b <*> g c + {-# INLINE liftToCon2 #-} + +instance (ToCon a c, ToCon b d) => ToCon2 ((,,,) a b) ((,,,) c d) where + liftToCon2 f g (a, b, c, d) = (,,,) <$> toCon a <*> toCon b <*> f c <*> g d + {-# INLINE liftToCon2 #-} diff --git a/src/Grisette/Internal/Core/Data/Class/ToSym.hs b/src/Grisette/Internal/Core/Data/Class/ToSym.hs --- a/src/Grisette/Internal/Core/Data/Class/ToSym.hs +++ b/src/Grisette/Internal/Core/Data/Class/ToSym.hs @@ -5,15 +5,17 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | -- Module : Grisette.Internal.Core.Data.Class.ToSym --- Copyright : (c) Sirui Lu 2021-2023 +-- Copyright : (c) Sirui Lu 2021-2024 -- License : BSD-3-Clause (see the LICENSE file) -- -- Maintainer : siruilu@cs.washington.edu @@ -22,11 +24,21 @@ module Grisette.Internal.Core.Data.Class.ToSym ( -- * Converting to symbolic values ToSym (..), + ToSym1 (..), + toSym1, + ToSym2 (..), + toSym2, + + -- * Generic 'ToSym' + ToSymArgs (..), + GToSym (..), + genericToSym, + genericLiftToSym, ) where import Control.Monad.Identity - ( Identity (Identity), + ( Identity (Identity, runIdentity), IdentityT (IdentityT), ) import Control.Monad.Reader (ReaderT (ReaderT)) @@ -37,22 +49,37 @@ import qualified Control.Monad.Writer.Lazy as WriterLazy import qualified Control.Monad.Writer.Strict as WriterStrict import qualified Data.ByteString as B +import Data.Functor.Compose (Compose (Compose)) +import Data.Functor.Const (Const) +import Data.Functor.Product (Product) import Data.Functor.Sum (Sum) import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import Data.Monoid (Alt, Ap) +import qualified Data.Monoid as Monoid +import Data.Ord (Down) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.TypeNats (KnownNat, type (<=)) import Generics.Deriving ( Default (Default), + Default1 (Default1), Generic (Rep, from, to), + Generic1 (Rep1, from1, to1), K1 (K1), M1 (M1), - U1, + Par1 (Par1), + Rec1 (Rec1), + U1 (U1), V1, + (:.:) (Comp1), type (:*:) ((:*:)), type (:+:) (L1, R1), ) -import Grisette.Internal.Core.Control.Exception (AssertionError, VerificationConditions) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) import Grisette.Internal.Core.Data.Class.BitCast (BitCast (bitCast)) import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) import Grisette.Internal.SymPrim.BV @@ -71,11 +98,21 @@ SymWordN, ) import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Internal.SymPrim.SymFP (SymFP, SymFP32, SymFP64, SymFPRoundingMode) +import Grisette.Internal.SymPrim.SymFP + ( SymFP, + SymFP32, + SymFP64, + SymFPRoundingMode, + ) import Grisette.Internal.SymPrim.SymGeneralFun (type (-~>)) import Grisette.Internal.SymPrim.SymInteger (SymInteger) import Grisette.Internal.SymPrim.SymTabularFun (type (=~>)) import Grisette.Internal.SymPrim.TabularFun (type (=->)) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) -- $setup -- >>> import Grisette.SymPrim @@ -91,6 +128,126 @@ -- [false,true] toSym :: a -> b +instance {-# INCOHERENT #-} ToSym a a where + toSym = id + {-# INLINE toSym #-} + +-- | Lifting of 'ToSym' to unary type constructors. +class (forall a b. (ToSym a b) => ToSym (f1 a) (f2 b)) => ToSym1 f1 f2 where + -- | Lift a conversion to symbolic function to unary type constructors. + liftToSym :: (a -> b) -> f1 a -> f2 b + +-- | Lift the standard 'toSym' to unary type constructors. +toSym1 :: (ToSym1 f1 f2, ToSym a b) => f1 a -> f2 b +toSym1 = liftToSym toSym +{-# INLINE toSym1 #-} + +-- | Lifting of 'ToSym' to binary type constructors. +class (forall a b. (ToSym a b) => ToSym1 (f1 a) (f2 b)) => ToSym2 f1 f2 where + -- | Lift conversion to symbolic functions to binary type constructors. + liftToSym2 :: (a -> b) -> (c -> d) -> f1 a c -> f2 b d + +-- | Lift the standard 'toSym' to binary type constructors. +toSym2 :: (ToSym2 f1 f2, ToSym a b, ToSym c d) => f1 a c -> f2 b d +toSym2 = liftToSym2 toSym toSym +{-# INLINE toSym2 #-} + +-- Derivations + +-- | The arguments to the generic 'toSym' function. +data family ToSymArgs arity a b :: Type + +data instance ToSymArgs Arity0 _ _ = ToSymArgs0 + +newtype instance ToSymArgs Arity1 a b = ToSymArgs1 (a -> b) + +-- | The class of types that can be generically converted to symbolic values. +class GToSym arity f1 f2 where + gtoSym :: ToSymArgs arity a b -> f1 a -> f2 b + +instance GToSym arity V1 V1 where + gtoSym _ _ = error "Impossible" + {-# INLINE gtoSym #-} + +instance GToSym arity U1 U1 where + gtoSym _ _ = U1 + {-# INLINE gtoSym #-} + +instance + (GToSym arity a b, GToSym arity c d) => + GToSym arity (a :+: c) (b :+: d) + where + gtoSym args (L1 a) = L1 $ gtoSym args a + gtoSym args (R1 b) = R1 $ gtoSym args b + {-# INLINE gtoSym #-} + +instance + (GToSym arity a b, GToSym arity c d) => + GToSym arity (a :*: c) (b :*: d) + where + gtoSym args (a :*: c) = gtoSym args a :*: gtoSym args c + {-# INLINE gtoSym #-} + +instance (ToSym a b) => GToSym arity (K1 i a) (K1 i b) where + gtoSym _ (K1 a) = K1 $ toSym a + {-# INLINE gtoSym #-} + +instance (GToSym arity f1 f2) => GToSym arity (M1 i c1 f1) (M1 i c2 f2) where + gtoSym args (M1 a) = M1 $ gtoSym args a + {-# INLINE gtoSym #-} + +instance GToSym Arity1 Par1 Par1 where + gtoSym (ToSymArgs1 f) (Par1 a) = Par1 $ f a + {-# INLINE gtoSym #-} + +instance (ToSym1 f1 f2) => GToSym Arity1 (Rec1 f1) (Rec1 f2) where + gtoSym (ToSymArgs1 f) (Rec1 a) = Rec1 $ liftToSym f a + {-# INLINE gtoSym #-} + +instance + (ToSym1 f1 f2, GToSym Arity1 g1 g2) => + GToSym Arity1 (f1 :.: g1) (f2 :.: g2) + where + gtoSym targs (Comp1 a) = Comp1 $ liftToSym (gtoSym targs) a + {-# INLINE gtoSym #-} + +-- | Generic 'toSym' function. +genericToSym :: + (Generic a, Generic b, GToSym Arity0 (Rep a) (Rep b)) => + a -> + b +genericToSym = to . gtoSym ToSymArgs0 . from +{-# INLINE genericToSym #-} + +-- | Generic 'liftToSym' function. +genericLiftToSym :: + (Generic1 f1, Generic1 f2, GToSym Arity1 (Rep1 f1) (Rep1 f2)) => + (a -> b) -> + f1 a -> + f2 b +genericLiftToSym f = to1 . gtoSym (ToSymArgs1 f) . from1 +{-# INLINE genericLiftToSym #-} + +instance + (Generic a, Generic b, GToSym Arity0 (Rep a) (Rep b)) => + ToSym a (Default b) + where + toSym = Default . genericToSym + {-# INLINE toSym #-} + +instance + (Generic1 f1, Generic1 f2, GToSym Arity1 (Rep1 f1) (Rep1 f2), ToSym a b) => + ToSym (f1 a) (Default1 f2 b) + where + toSym = toSym1 + +instance + (Generic1 f1, Generic1 f2, GToSym Arity1 (Rep1 f1) (Rep1 f2)) => + ToSym1 f1 (Default1 f2) + where + liftToSym f = Default1 . genericLiftToSym f + {-# INLINE liftToSym #-} + #define CONCRETE_TOSYM(type) \ instance ToSym type type where \ toSym = id @@ -120,114 +277,14 @@ CONCRETE_TOSYM(FPRoundingMode) CONCRETE_TOSYM_BV(IntN) CONCRETE_TOSYM_BV(WordN) +CONCRETE_TOSYM(Monoid.All) +CONCRETE_TOSYM(Monoid.Any) +CONCRETE_TOSYM(Ordering) #endif instance (ValidFP eb sb) => ToSym (FP eb sb) (FP eb sb) where toSym = id --- Unit -instance ToSym () () where - toSym = id - --- Either -deriving via (Default (Either e2 a2)) instance (ToSym e1 e2, ToSym a1 a2) => ToSym (Either e1 a1) (Either e2 a2) - --- Maybe -deriving via (Default (Maybe b)) instance (ToSym a b) => ToSym (Maybe a) (Maybe b) - --- List -deriving via (Default [b]) instance (ToSym a b) => ToSym [a] [b] - --- (,) -deriving via (Default (b1, b2)) instance (ToSym a1 b1, ToSym a2 b2) => ToSym (a1, a2) (b1, b2) - --- (,,) -deriving via (Default (b1, b2, b3)) instance (ToSym a1 b1, ToSym a2 b2, ToSym a3 b3) => ToSym (a1, a2, a3) (b1, b2, b3) - --- (,,,) -deriving via - (Default (a2, b2, c2, d2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2) => ToSym (a1, b1, c1, d1) (a2, b2, c2, d2) - --- (,,,,) -deriving via - (Default (a2, b2, c2, d2, e2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2) => - ToSym (a1, b1, c1, d1, e1) (a2, b2, c2, d2, e2) - --- (,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2) => - ToSym (a1, b1, c1, d1, e1, f1) (a2, b2, c2, d2, e2, f2) - --- (,,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2, g2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2, ToSym g1 g2) => - ToSym (a1, b1, c1, d1, e1, f1, g1) (a2, b2, c2, d2, e2, f2, g2) - --- (,,,,,,,) -deriving via - (Default (a2, b2, c2, d2, e2, f2, g2, h2)) - instance - (ToSym a1 a2, ToSym b1 b2, ToSym c1 c2, ToSym d1 d2, ToSym e1 e2, ToSym f1 f2, ToSym g1 g2, ToSym h1 h2) => - ToSym (a1, b1, c1, d1, e1, f1, g1, h1) (a2, b2, c2, d2, e2, f2, g2, h2) - --- function -instance (ToSym a b) => ToSym (v -> a) (v -> b) where - toSym f = toSym . f - --- MaybeT -instance - (ToSym (m1 (Maybe a)) (m2 (Maybe b))) => - ToSym (MaybeT m1 a) (MaybeT m2 b) - where - toSym (MaybeT v) = MaybeT $ toSym v - --- ExceptT -instance - (ToSym (m1 (Either e1 a)) (m2 (Either e2 b))) => - ToSym (ExceptT e1 m1 a) (ExceptT e2 m2 b) - where - toSym (ExceptT v) = ExceptT $ toSym v - --- StateT -instance (ToSym (s1 -> m1 (a1, s1)) (s2 -> m2 (a2, s2))) => ToSym (StateLazy.StateT s1 m1 a1) (StateLazy.StateT s2 m2 a2) where - toSym (StateLazy.StateT f1) = StateLazy.StateT $ toSym f1 - -instance (ToSym (s1 -> m1 (a1, s1)) (s2 -> m2 (a2, s2))) => ToSym (StateStrict.StateT s1 m1 a1) (StateStrict.StateT s2 m2 a2) where - toSym (StateStrict.StateT f1) = StateStrict.StateT $ toSym f1 - --- WriterT -instance (ToSym (m1 (a1, s1)) (m2 (a2, s2))) => ToSym (WriterLazy.WriterT s1 m1 a1) (WriterLazy.WriterT s2 m2 a2) where - toSym (WriterLazy.WriterT f1) = WriterLazy.WriterT $ toSym f1 - -instance (ToSym (m1 (a1, s1)) (m2 (a2, s2))) => ToSym (WriterStrict.WriterT s1 m1 a1) (WriterStrict.WriterT s2 m2 a2) where - toSym (WriterStrict.WriterT f1) = WriterStrict.WriterT $ toSym f1 - --- ReaderT -instance (ToSym (s1 -> m1 a1) (s2 -> m2 a2)) => ToSym (ReaderT s1 m1 a1) (ReaderT s2 m2 a2) where - toSym (ReaderT f1) = ReaderT $ toSym f1 - --- Sum -deriving via - (Default (Sum f1 g1 a1)) - instance - (ToSym (f a) (f1 a1), ToSym (g a) (g1 a1)) => ToSym (Sum f g a) (Sum f1 g1 a1) - --- Identity -instance (ToSym a b) => ToSym (Identity a) (Identity b) where - toSym (Identity a) = Identity $ toSym a - --- IdentityT -instance (ToSym (m a) (m1 b)) => ToSym (IdentityT m a) (IdentityT m1 b) where - toSym (IdentityT v) = IdentityT $ toSym v - #define TO_SYM_SYMID_SIMPLE(symtype) \ instance ToSym symtype symtype where \ toSym = id @@ -304,38 +361,333 @@ toSym = con . bitCast {-# INLINE toSym #-} --- Exception +deriveBuiltins + (ViaDefault ''ToSym) + [''ToSym] + [ ''[], + ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +deriveBuiltins + (ViaDefault1 ''ToSym1) + [''ToSym, ''ToSym1] + [ ''[], + ''Maybe, + ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Monoid.Dual, + ''Monoid.Sum, + ''Monoid.Product, + ''Monoid.First, + ''Monoid.Last, + ''Down + ] + +-- ExceptT +instance + (ToSym1 m1 m2, ToSym e1 e2, ToSym a b) => + ToSym (ExceptT e1 m1 a) (ExceptT e2 m2 b) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym1 m1 m2, ToSym e1 e2) => + ToSym1 (ExceptT e1 m1) (ExceptT e2 m2) + where + liftToSym f (ExceptT v) = ExceptT $ liftToSym (liftToSym f) v + {-# INLINE liftToSym #-} + +-- MaybeT +instance + (ToSym1 m1 m2, ToSym a b) => + ToSym (MaybeT m1 a) (MaybeT m2 b) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym1 m1 m2) => + ToSym1 (MaybeT m1) (MaybeT m2) + where + liftToSym f (MaybeT v) = MaybeT $ liftToSym (liftToSym f) v + {-# INLINE liftToSym #-} + +-- WriterT +instance + (ToSym1 m1 m2, ToSym a b, ToSym s1 s2) => + ToSym (WriterLazy.WriterT s1 m1 a) (WriterLazy.WriterT s2 m2 b) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym1 m1 m2, ToSym s1 s2) => + ToSym1 (WriterLazy.WriterT s1 m1) (WriterLazy.WriterT s2 m2) + where + liftToSym f (WriterLazy.WriterT v) = + WriterLazy.WriterT $ liftToSym (liftToSym2 f toSym) v + {-# INLINE liftToSym #-} + +instance + (ToSym1 m1 m2, ToSym a b, ToSym s1 s2) => + ToSym (WriterStrict.WriterT s1 m1 a) (WriterStrict.WriterT s2 m2 b) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym1 m1 m2, ToSym s1 s2) => + ToSym1 (WriterStrict.WriterT s1 m1) (WriterStrict.WriterT s2 m2) + where + liftToSym f (WriterStrict.WriterT v) = + WriterStrict.WriterT $ liftToSym (liftToSym2 f toSym) v + {-# INLINE liftToSym #-} + +-- StateT +instance + (ToSym1 m1 m2, ToSym a1 a2) => + ToSym (StateLazy.StateT s m1 a1) (StateLazy.StateT s m2 a2) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym1 m1 m2) => + ToSym1 (StateLazy.StateT s m1) (StateLazy.StateT s m2) + where + liftToSym f (StateLazy.StateT f1) = + StateLazy.StateT $ \s -> liftToSym (liftToSym2 f id) $ f1 s + {-# INLINE liftToSym #-} + +instance + (ToSym1 m1 m2, ToSym a1 a2) => + ToSym (StateStrict.StateT s m1 a1) (StateStrict.StateT s m2 a2) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym1 m1 m2) => + ToSym1 (StateStrict.StateT s m1) (StateStrict.StateT s m2) + where + liftToSym f (StateStrict.StateT f1) = + StateStrict.StateT $ \s -> liftToSym (liftToSym2 f id) $ f1 s + {-# INLINE liftToSym #-} + +-- ReaderT +instance + (ToSym s2 s1, ToSym1 m1 m2, ToSym a1 a2) => + ToSym (ReaderT s1 m1 a1) (ReaderT s2 m2 a2) + where + toSym = toSym1 + {-# INLINE toSym #-} + +instance + (ToSym s2 s1, ToSym1 m1 m2) => + ToSym1 (ReaderT s1 m1) (ReaderT s2 m2) + where + liftToSym f (ReaderT f1) = ReaderT $ liftToSym (liftToSym f) f1 + {-# INLINE liftToSym #-} + +-- IdentityT +instance (ToSym1 m m1, ToSym a b) => ToSym (IdentityT m a) (IdentityT m1 b) where + toSym = toSym1 + {-# INLINE toSym #-} + +instance (ToSym1 m m1) => ToSym1 (IdentityT m) (IdentityT m1) where + liftToSym f (IdentityT v) = IdentityT $ liftToSym f v + {-# INLINE liftToSym #-} + +-- Identity +instance {-# INCOHERENT #-} (ToSym a b) => ToSym (Identity a) (Identity b) where + toSym = toSym1 + {-# INLINE toSym #-} + +instance {-# INCOHERENT #-} (ToSym a b) => ToSym a (Identity b) where + toSym = Identity . toSym + {-# INLINE toSym #-} + +instance {-# INCOHERENT #-} (ToSym a b) => ToSym (Identity a) b where + toSym = toSym . runIdentity + {-# INLINE toSym #-} + +instance ToSym1 Identity Identity where + liftToSym f (Identity v) = Identity $ f v + {-# INLINE liftToSym #-} + +-- Function +instance (ToSym b d, ToSym c a) => ToSym (a -> b) (c -> d) where + toSym = toSym1 + {-# INLINE toSym #-} + +instance (ToSym c a) => ToSym1 ((->) a) ((->) c) where + liftToSym l f = l . f . toSym + {-# INLINE liftToSym #-} + +-- Product deriving via - (Default AssertionError) + (Default (Product l r a)) instance - ToSym AssertionError AssertionError + (ToSym (l0 a0) (l a), ToSym (r0 a0) (r a)) => + ToSym (Product l0 r0 a0) (Product l r a) deriving via - (Default VerificationConditions) + (Default1 (Product l r)) instance - ToSym VerificationConditions VerificationConditions + (ToSym1 l0 l, ToSym1 r0 r) => ToSym1 (Product l0 r0) (Product l r) -instance (Generic a, Generic b, ToSym' (Rep a) (Rep b)) => ToSym a (Default b) where - toSym = Default . to . toSym' . from +-- Sum +deriving via + (Default (Sum l r a)) + instance + (ToSym (l0 a0) (l a), ToSym (r0 a0) (r a)) => + ToSym (Sum l0 r0 a0) (Sum l r a) -class ToSym' a b where - toSym' :: a c -> b c +deriving via + (Default1 (Sum l r)) + instance + (ToSym1 l0 l, ToSym1 r0 r) => ToSym1 (Sum l0 r0) (Sum l r) -instance ToSym' U1 U1 where - toSym' = id +-- Compose +deriving via + (Default (Compose f g a)) + instance + (ToSym (f0 (g0 a0)) (f (g a))) => ToSym (Compose f0 g0 a0) (Compose f g a) -instance ToSym' V1 V1 where - toSym' = id +instance + (ToSym1 f0 f, ToSym1 g0 g) => + ToSym1 (Compose f0 g0) (Compose f g) + where + liftToSym f (Compose v) = Compose $ liftToSym (liftToSym f) v + {-# INLINE liftToSym #-} -instance (ToSym a b) => ToSym' (K1 i a) (K1 i b) where - toSym' (K1 a) = K1 $ toSym a +-- Const +deriving via + (Default (Const a b)) + instance + (ToSym a0 a) => ToSym (Const a0 b0) (Const a b) -instance (ToSym' a b) => ToSym' (M1 i c1 a) (M1 i c2 b) where - toSym' (M1 a) = M1 $ toSym' a +deriving via + (Default1 (Const a)) + instance + (ToSym a0 a) => ToSym1 (Const a0) (Const a) -instance (ToSym' a1 a2, ToSym' b1 b2) => ToSym' (a1 :+: b1) (a2 :+: b2) where - toSym' (L1 a) = L1 $ toSym' a - toSym' (R1 b) = R1 $ toSym' b +-- Alt +deriving via + (Default (Alt f a)) + instance + (ToSym (f0 a0) (f a)) => ToSym (Alt f0 a0) (Alt f a) -instance (ToSym' a1 a2, ToSym' b1 b2) => ToSym' (a1 :*: b1) (a2 :*: b2) where - toSym' (a :*: b) = toSym' a :*: toSym' b +deriving via + (Default1 (Alt f)) + instance + (ToSym1 f0 f) => ToSym1 (Alt f0) (Alt f) + +-- Ap +deriving via + (Default (Ap f a)) + instance + (ToSym (f0 a0) (f a)) => ToSym (Ap f0 a0) (Ap f a) + +deriving via + (Default1 (Ap f)) + instance + (ToSym1 f0 f) => ToSym1 (Ap f0) (Ap f) + +-- Generic +deriving via (Default (U1 p)) instance ToSym (U1 p0) (U1 p) + +deriving via (Default (V1 p)) instance ToSym (V1 p0) (V1 p) + +deriving via + (Default (K1 i c p)) + instance + (ToSym c0 c) => ToSym (K1 i0 c0 p0) (K1 i c p) + +deriving via + (Default (M1 i c f p)) + instance + (ToSym (f0 p0) (f p)) => ToSym (M1 i0 c0 f0 p0) (M1 i c f p) + +deriving via + (Default ((f :+: g) p)) + instance + (ToSym (f0 p0) (f p), ToSym (g0 p0) (g p)) => + ToSym ((f0 :+: g0) p0) ((f :+: g) p) + +deriving via + (Default ((f :*: g) p)) + instance + (ToSym (f0 p0) (f p), ToSym (g0 p0) (g p)) => + ToSym ((f0 :*: g0) p0) ((f :*: g) p) + +deriving via + (Default (Par1 p)) + instance + (ToSym p0 p) => ToSym (Par1 p0) (Par1 p) + +deriving via + (Default (Rec1 f p)) + instance + (ToSym (f0 p0) (f p)) => ToSym (Rec1 f0 p0) (Rec1 f p) + +deriving via + (Default ((f :.: g) p)) + instance + (ToSym (f0 (g0 p0)) (f (g p))) => ToSym ((f0 :.: g0) p0) ((f :.: g) p) + +-- ToSym2 +instance ToSym2 Either Either where + liftToSym2 f _ (Left a) = Left $ f a + liftToSym2 _ g (Right b) = Right $ g b + {-# INLINE liftToSym2 #-} + +instance ToSym2 (,) (,) where + liftToSym2 f g (a, b) = (f a, g b) + {-# INLINE liftToSym2 #-} + +instance (ToSym a b) => ToSym2 ((,,) a) ((,,) b) where + liftToSym2 f g (a, b, c) = (toSym a, f b, g c) + {-# INLINE liftToSym2 #-} + +instance (ToSym a c, ToSym b d) => ToSym2 ((,,,) a b) ((,,,) c d) where + liftToSym2 f g (a, b, c, d) = (toSym a, toSym b, f c, g d) + {-# INLINE liftToSym2 #-} diff --git a/src/Grisette/Internal/Core/Data/Class/TryMerge.hs b/src/Grisette/Internal/Core/Data/Class/TryMerge.hs --- a/src/Grisette/Internal/Core/Data/Class/TryMerge.hs +++ b/src/Grisette/Internal/Core/Data/Class/TryMerge.hs @@ -67,7 +67,7 @@ -- | Wrap a value in the applicative functor and capture the 'Mergeable' -- knowledge. -- --- >>> mrgSingleWithStrategy rootStrategy "a" :: UnionM SymInteger +-- >>> mrgSingleWithStrategy rootStrategy "a" :: Union SymInteger -- {a} -- -- __Note:__ Be careful to call this directly from your code. @@ -77,7 +77,8 @@ -- -- This function is to be called when the 'Mergeable' constraint can not be -- resolved, e.g., the merge strategy for the contained type is given with --- 'Mergeable1'. In other cases, 'mrgPure' is usually a better alternative. +-- 'Mergeable1'. In other cases, 'Grisette.Lib.Control.Applicative.mrgPure' +-- is usually a better alternative. mrgSingleWithStrategy :: (TryMerge m, Applicative m) => MergingStrategy a -> @@ -91,7 +92,7 @@ -- -- Equivalent to @'mrgSingleWithStrategy' 'rootStrategy'@. -- --- >>> mrgSingle "a" :: UnionM SymInteger +-- >>> mrgSingle "a" :: Union SymInteger -- {a} mrgSingle :: (TryMerge m, Applicative m, Mergeable a) => a -> m a mrgSingle = mrgSingleWithStrategy rootStrategy diff --git a/src/Grisette/Internal/Core/Data/Symbol.hs b/src/Grisette/Internal/Core/Data/Symbol.hs --- a/src/Grisette/Internal/Core/Data/Symbol.hs +++ b/src/Grisette/Internal/Core/Data/Symbol.hs @@ -44,7 +44,7 @@ import Language.Haskell.TH.Syntax (Lift (liftTyped), unsafeTExpCoerce) import Language.Haskell.TH.Syntax.Compat (SpliceQ, liftSplice) --- | Identifier type used for 'GenSym' +-- | Identifier type used for 'Grisette.Core.GenSym' -- -- The constructor is hidden intentionally. -- You can construct an identifier by: @@ -209,6 +209,7 @@ instance Show UniqueCount where show (UniqueCount i) = "unique<" <> show i <> ">" +-- | Get a globally unique identifier within the 'IO' monad. uniqueIdentifier :: T.Text -> IO Identifier uniqueIdentifier ident = do i <- atomicModifyIORef' identifierCount (\x -> (x + 1, x)) diff --git a/src/Grisette/Internal/Core/Data/Union.hs b/src/Grisette/Internal/Core/Data/Union.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core/Data/Union.hs +++ /dev/null @@ -1,322 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TypeFamilies #-} - --- | --- Module : Grisette.Internal.Core.Data.Union --- Copyright : (c) Sirui Lu 2021-2023 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.Data.Union - ( -- * The union data structure. - - -- | Please consider using 'Grisette.Internal.Core.Control.Monad.UnionM' instead. - Union (..), - ifWithLeftMost, - ifWithStrategy, - fullReconstruct, - ) -where - -import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) -import Control.Monad (ap) -import Data.Functor.Classes - ( Eq1 (liftEq), - Show1 (liftShowsPrec), - showsPrec1, - showsUnaryWith, - ) -import Data.Hashable (Hashable (hashWithSalt)) -import GHC.Generics (Generic, Generic1) -import Grisette.Internal.Core.Data.Class.GPretty - ( GPretty (gprettyPrec), - condEnclose, - ) -import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) -import Grisette.Internal.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - Mergeable1 (liftRootStrategy), - MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy), - ) -import Grisette.Internal.Core.Data.Class.PlainUnion - ( PlainUnion (ifView, singleView), - ) -import Grisette.Internal.Core.Data.Class.SimpleMergeable - ( SimpleMergeable (mrgIte), - SimpleMergeable1 (liftMrgIte), - UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), - mrgIf, - ) -import Grisette.Internal.Core.Data.Class.Solvable (pattern Con) -import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge (tryMergeWithStrategy)) -import Grisette.Internal.SymPrim.AllSyms - ( AllSyms (allSymsS), - SomeSym (SomeSym), - ) -import Grisette.Internal.SymPrim.SymBool (SymBool) -import Language.Haskell.TH.Syntax (Lift) - -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter (align, group, nest, vsep) -#else -import Data.Text.Prettyprint.Doc (align, group, nest, vsep) -#endif - --- | The default union implementation. -data Union a where - -- | A single value - UnionSingle :: a -> Union a - -- | A if value - UnionIf :: - -- | Cached leftmost value - a -> - -- | Is merged invariant already maintained? - !Bool -> - -- | If condition - !SymBool -> - -- | True branch - Union a -> - -- | False branch - Union a -> - Union a - deriving (Generic, Eq, Lift, Generic1) - deriving (Functor) - -instance Applicative Union where - pure = UnionSingle - {-# INLINE pure #-} - (<*>) = ap - {-# INLINE (<*>) #-} - -instance Monad Union where - return = pure - {-# INLINE return #-} - UnionSingle a >>= f = f a - UnionIf _ _ c t f >>= f' = ifWithLeftMost False c (t >>= f') (f >>= f') - {-# INLINE (>>=) #-} - -instance Eq1 Union where - liftEq e (UnionSingle a) (UnionSingle b) = e a b - liftEq e (UnionIf l1 i1 c1 t1 f1) (UnionIf l2 i2 c2 t2 f2) = - e l1 l2 && i1 == i2 && c1 == c2 && liftEq e t1 t2 && liftEq e f1 f2 - liftEq _ _ _ = False - -instance (NFData a) => NFData (Union a) where - rnf = rnf1 - -instance NFData1 Union where - liftRnf _a (UnionSingle a) = _a a - liftRnf _a (UnionIf a bo b l r) = - _a a `seq` - rnf bo `seq` - rnf b `seq` - liftRnf _a l `seq` - liftRnf _a r - --- | Build 'UnionIf' with leftmost cache correctly maintained. --- --- Usually you should never directly try to build a 'UnionIf' with its --- constructor. -ifWithLeftMost :: Bool -> SymBool -> Union a -> Union a -> Union a -ifWithLeftMost _ (Con c) t f - | c = t - | otherwise = f -ifWithLeftMost inv cond t f = UnionIf (leftMost t) inv cond t f -{-# INLINE ifWithLeftMost #-} - -instance PlainUnion Union where - singleView (UnionSingle a) = Just a - singleView _ = Nothing - {-# INLINE singleView #-} - ifView (UnionIf _ _ cond ifTrue ifFalse) = Just (cond, ifTrue, ifFalse) - ifView _ = Nothing - {-# INLINE ifView #-} - -leftMost :: Union a -> a -leftMost (UnionSingle a) = a -leftMost (UnionIf a _ _ _ _) = a -{-# INLINE leftMost #-} - -instance (Mergeable a) => Mergeable (Union a) where - rootStrategy = SimpleStrategy $ ifWithStrategy rootStrategy - {-# INLINE rootStrategy #-} - -instance Mergeable1 Union where - liftRootStrategy ms = SimpleStrategy $ ifWithStrategy ms - {-# INLINE liftRootStrategy #-} - -instance (Mergeable a) => SimpleMergeable (Union a) where - mrgIte = mrgIf - -instance SimpleMergeable1 Union where - liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) - -instance TryMerge Union where - tryMergeWithStrategy = fullReconstruct - {-# INLINE tryMergeWithStrategy #-} - -instance UnionMergeable1 Union where - mrgIfWithStrategy = ifWithStrategy - {-# INLINE mrgIfWithStrategy #-} - - mrgIfPropagatedStrategy = ifWithLeftMost False - {-# INLINE mrgIfPropagatedStrategy #-} - -instance Show1 Union where - liftShowsPrec sp _ i (UnionSingle a) = showsUnaryWith sp "Single" i a - liftShowsPrec sp sl i (UnionIf _ _ cond t f) = - showParen (i > 10) $ - showString "If" - . showChar ' ' - . showsPrec 11 cond - . showChar ' ' - . sp1 11 t - . showChar ' ' - . sp1 11 f - where - sp1 = liftShowsPrec sp sl - -instance (Show a) => Show (Union a) where - showsPrec = showsPrec1 - -instance (GPretty a) => GPretty (Union a) where - gprettyPrec n (UnionSingle a) = gprettyPrec n a - gprettyPrec n (UnionIf _ _ cond t f) = - group $ - condEnclose (n > 10) "(" ")" $ - align $ - nest 2 $ - vsep - [ "If", - gprettyPrec 11 cond, - gprettyPrec 11 t, - gprettyPrec 11 f - ] - -instance (Hashable a) => Hashable (Union a) where - s `hashWithSalt` (UnionSingle a) = - s `hashWithSalt` (0 :: Int) `hashWithSalt` a - s `hashWithSalt` (UnionIf _ _ c l r) = - s - `hashWithSalt` (1 :: Int) - `hashWithSalt` c - `hashWithSalt` l - `hashWithSalt` r - -instance (AllSyms a) => AllSyms (Union a) where - allSymsS (UnionSingle v) = allSymsS v - allSymsS (UnionIf _ _ c t f) = \l -> SomeSym c : (allSymsS t . allSymsS f $ l) - --- | Fully reconstruct a 'Union' to maintain the merged invariant. -fullReconstruct :: MergingStrategy a -> Union a -> Union a -fullReconstruct strategy (UnionIf _ False cond t f) = - ifWithStrategyInv - strategy - cond - (fullReconstruct strategy t) - (fullReconstruct strategy f) -fullReconstruct _ u = u -{-# INLINE fullReconstruct #-} - --- | Use a specific strategy to build a 'UnionIf' value. --- --- The merged invariant will be maintained in the result. -ifWithStrategy :: - MergingStrategy a -> - SymBool -> - Union a -> - Union a -> - Union a -ifWithStrategy strategy cond t@(UnionIf _ False _ _ _) f = - ifWithStrategy strategy cond (fullReconstruct strategy t) f -ifWithStrategy strategy cond t f@(UnionIf _ False _ _ _) = - ifWithStrategy strategy cond t (fullReconstruct strategy f) -ifWithStrategy strategy cond t f = ifWithStrategyInv strategy cond t f -{-# INLINE ifWithStrategy #-} - -ifWithStrategyInv :: - MergingStrategy a -> - SymBool -> - Union a -> - Union a -> - Union a -ifWithStrategyInv _ (Con v) t f - | v = t - | otherwise = f -ifWithStrategyInv strategy cond (UnionIf _ True condTrue tt _) f - | cond == condTrue = ifWithStrategyInv strategy cond tt f --- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond ft f -ifWithStrategyInv strategy cond t (UnionIf _ True condFalse _ ff) - | cond == condFalse = ifWithStrategyInv strategy cond t ff --- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond t tf -- buggy here condTrue -ifWithStrategyInv (SimpleStrategy m) cond (UnionSingle l) (UnionSingle r) = UnionSingle $ m cond l r -ifWithStrategyInv strategy@(SortedStrategy idxFun substrategy) cond ifTrue ifFalse = case (ifTrue, ifFalse) of - (UnionSingle _, UnionSingle _) -> ssUnionIf cond ifTrue ifFalse - (UnionSingle _, UnionIf {}) -> sgUnionIf cond ifTrue ifFalse - (UnionIf {}, UnionSingle _) -> gsUnionIf cond ifTrue ifFalse - _ -> ggUnionIf cond ifTrue ifFalse - where - ssUnionIf cond' ifTrue' ifFalse' - | idxt < idxf = ifWithLeftMost True cond' ifTrue' ifFalse' - | idxt == idxf = ifWithStrategyInv (substrategy idxt) cond' ifTrue' ifFalse' - | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' - where - idxt = idxFun $ leftMost ifTrue' - idxf = idxFun $ leftMost ifFalse' - {-# INLINE ssUnionIf #-} - sgUnionIf cond' ifTrue' ifFalse'@(UnionIf _ True condf ft ff) - | idxft == idxff = ssUnionIf cond' ifTrue' ifFalse' - | idxt < idxft = ifWithLeftMost True cond' ifTrue' ifFalse' - | idxt == idxft = ifWithLeftMost True (cond' .|| condf) (ifWithStrategyInv (substrategy idxt) cond' ifTrue' ft) ff - | otherwise = ifWithLeftMost True (symNot cond' .&& condf) ft (ifWithStrategyInv strategy cond' ifTrue' ff) - where - idxft = idxFun $ leftMost ft - idxff = idxFun $ leftMost ff - idxt = idxFun $ leftMost ifTrue' - sgUnionIf _ _ _ = undefined - {-# INLINE sgUnionIf #-} - gsUnionIf cond' ifTrue'@(UnionIf _ True condt tt tf) ifFalse' - | idxtt == idxtf = ssUnionIf cond' ifTrue' ifFalse' - | idxtt < idxf = ifWithLeftMost True (cond' .&& condt) tt $ ifWithStrategyInv strategy cond' tf ifFalse' - | idxtt == idxf = ifWithLeftMost True (symNot cond' .|| condt) (ifWithStrategyInv (substrategy idxf) cond' tt ifFalse') tf - | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' - where - idxtt = idxFun $ leftMost tt - idxtf = idxFun $ leftMost tf - idxf = idxFun $ leftMost ifFalse' - gsUnionIf _ _ _ = undefined - {-# INLINE gsUnionIf #-} - ggUnionIf cond' ifTrue'@(UnionIf _ True condt tt tf) ifFalse'@(UnionIf _ True condf ft ff) - | idxtt == idxtf = sgUnionIf cond' ifTrue' ifFalse' - | idxft == idxff = gsUnionIf cond' ifTrue' ifFalse' - | idxtt < idxft = ifWithLeftMost True (cond' .&& condt) tt $ ifWithStrategyInv strategy cond' tf ifFalse' - | idxtt == idxft = - let newCond = symIte cond' condt condf - newUnionIfTrue = ifWithStrategyInv (substrategy idxtt) cond' tt ft - newUnionIfFalse = ifWithStrategyInv strategy cond' tf ff - in ifWithLeftMost True newCond newUnionIfTrue newUnionIfFalse - | otherwise = ifWithLeftMost True (symNot cond' .&& condf) ft $ ifWithStrategyInv strategy cond' ifTrue' ff - where - idxtt = idxFun $ leftMost tt - idxtf = idxFun $ leftMost tf - idxft = idxFun $ leftMost ft - idxff = idxFun $ leftMost ff - ggUnionIf _ _ _ = undefined - {-# INLINE ggUnionIf #-} -ifWithStrategyInv NoStrategy cond ifTrue ifFalse = ifWithLeftMost True cond ifTrue ifFalse -ifWithStrategyInv _ _ _ _ = error "Invariant violated" -{-# INLINE ifWithStrategyInv #-} diff --git a/src/Grisette/Internal/Core/Data/UnionBase.hs b/src/Grisette/Internal/Core/Data/UnionBase.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Core/Data/UnionBase.hs @@ -0,0 +1,369 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.Core.Data.UnionBase +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Core.Data.UnionBase + ( -- * The union data structure. + + -- | Please consider using 'Grisette.Core.Union' instead. + UnionBase (..), + ifWithLeftMost, + ifWithStrategy, + fullReconstruct, + ) +where + +import Control.DeepSeq (NFData (rnf), NFData1 (liftRnf), rnf1) +import Control.Monad (ap) +import Data.Functor.Classes + ( Eq1 (liftEq), + Show1 (liftShowsPrec), + showsPrec1, + showsUnaryWith, + ) +import Data.Hashable (Hashable (hashWithSalt)) +import GHC.Generics (Generic, Generic1) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (symNot, (.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + Mergeable1 (liftRootStrategy), + MergingStrategy (NoStrategy, SimpleStrategy, SortedStrategy), + ) +import Grisette.Internal.Core.Data.Class.PPrint + ( PPrint (pformatPrec), + PPrint1 (liftPFormatPrec), + condEnclose, + pformatPrec1, + ) +import Grisette.Internal.Core.Data.Class.PlainUnion + ( PlainUnion (ifView, singleView), + ) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable (mrgIte), + SimpleMergeable1 (liftMrgIte), + SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), + mrgIf, + ) +import Grisette.Internal.Core.Data.Class.Solvable (pattern Con) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge (tryMergeWithStrategy), + ) +import Grisette.Internal.SymPrim.AllSyms + ( AllSyms (allSymsS), + AllSyms1 (liftAllSymsS), + SomeSym (SomeSym), + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Language.Haskell.TH.Syntax (Lift) + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter (align, group, nest, vsep) +#else +import Data.Text.Prettyprint.Doc (align, group, nest, vsep) +#endif + +-- | The base union implementation, which is an if-then-else tree structure. +data UnionBase a where + -- | A single value + UnionSingle :: a -> UnionBase a + -- | A if value + UnionIf :: + -- | Cached leftmost value + a -> + -- | Is merged invariant already maintained? + !Bool -> + -- | If condition + !SymBool -> + -- | True branch + UnionBase a -> + -- | False branch + UnionBase a -> + UnionBase a + deriving (Generic, Eq, Lift, Generic1) + deriving (Functor) + +instance Applicative UnionBase where + pure = UnionSingle + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + +instance Monad UnionBase where + return = pure + {-# INLINE return #-} + UnionSingle a >>= f = f a + UnionIf _ _ c t f >>= f' = ifWithLeftMost False c (t >>= f') (f >>= f') + {-# INLINE (>>=) #-} + +instance Eq1 UnionBase where + liftEq e (UnionSingle a) (UnionSingle b) = e a b + liftEq e (UnionIf l1 i1 c1 t1 f1) (UnionIf l2 i2 c2 t2 f2) = + e l1 l2 && i1 == i2 && c1 == c2 && liftEq e t1 t2 && liftEq e f1 f2 + liftEq _ _ _ = False + +instance (NFData a) => NFData (UnionBase a) where + rnf = rnf1 + +instance NFData1 UnionBase where + liftRnf _a (UnionSingle a) = _a a + liftRnf _a (UnionIf a bo b l r) = + _a a `seq` + rnf bo `seq` + rnf b `seq` + liftRnf _a l `seq` + liftRnf _a r + +-- | Build 'UnionIf' with leftmost cache correctly maintained. +-- +-- Usually you should never directly try to build a 'UnionIf' with its +-- constructor. +ifWithLeftMost :: Bool -> SymBool -> UnionBase a -> UnionBase a -> UnionBase a +ifWithLeftMost _ (Con c) t f + | c = t + | otherwise = f +ifWithLeftMost inv cond t f = UnionIf (leftMost t) inv cond t f +{-# INLINE ifWithLeftMost #-} + +instance PlainUnion UnionBase where + singleView (UnionSingle a) = Just a + singleView _ = Nothing + {-# INLINE singleView #-} + ifView (UnionIf _ _ cond ifTrue ifFalse) = Just (cond, ifTrue, ifFalse) + ifView _ = Nothing + {-# INLINE ifView #-} + +leftMost :: UnionBase a -> a +leftMost (UnionSingle a) = a +leftMost (UnionIf a _ _ _ _) = a +{-# INLINE leftMost #-} + +instance (Mergeable a) => Mergeable (UnionBase a) where + rootStrategy = SimpleStrategy $ ifWithStrategy rootStrategy + {-# INLINE rootStrategy #-} + +instance Mergeable1 UnionBase where + liftRootStrategy ms = SimpleStrategy $ ifWithStrategy ms + {-# INLINE liftRootStrategy #-} + +instance (Mergeable a) => SimpleMergeable (UnionBase a) where + mrgIte = mrgIf + +instance SimpleMergeable1 UnionBase where + liftMrgIte m = mrgIfWithStrategy (SimpleStrategy m) + +instance TryMerge UnionBase where + tryMergeWithStrategy = fullReconstruct + {-# INLINE tryMergeWithStrategy #-} + +instance SymBranching UnionBase where + mrgIfWithStrategy = ifWithStrategy + {-# INLINE mrgIfWithStrategy #-} + + mrgIfPropagatedStrategy = ifWithLeftMost False + {-# INLINE mrgIfPropagatedStrategy #-} + +instance Show1 UnionBase where + liftShowsPrec sp _ i (UnionSingle a) = showsUnaryWith sp "Single" i a + liftShowsPrec sp sl i (UnionIf _ _ cond t f) = + showParen (i > 10) $ + showString "If" + . showChar ' ' + . showsPrec 11 cond + . showChar ' ' + . sp1 11 t + . showChar ' ' + . sp1 11 f + where + sp1 = liftShowsPrec sp sl + +instance (Show a) => Show (UnionBase a) where + showsPrec = showsPrec1 + +instance (PPrint a) => PPrint (UnionBase a) where + pformatPrec = pformatPrec1 + +instance PPrint1 UnionBase where + liftPFormatPrec fa _ n (UnionSingle a) = fa n a + liftPFormatPrec fa fl n (UnionIf _ _ cond t f) = + group $ + condEnclose (n > 10) "(" ")" $ + align $ + nest 2 $ + vsep + [ "If", + pformatPrec 11 cond, + liftPFormatPrec fa fl 11 t, + liftPFormatPrec fa fl 11 f + ] + +instance (Hashable a) => Hashable (UnionBase a) where + s `hashWithSalt` (UnionSingle a) = + s `hashWithSalt` (0 :: Int) `hashWithSalt` a + s `hashWithSalt` (UnionIf _ _ c l r) = + s + `hashWithSalt` (1 :: Int) + `hashWithSalt` c + `hashWithSalt` l + `hashWithSalt` r + +instance (AllSyms a) => AllSyms (UnionBase a) where + allSymsS (UnionSingle v) = allSymsS v + allSymsS (UnionIf _ _ c t f) = \l -> SomeSym c : (allSymsS t . allSymsS f $ l) + +instance AllSyms1 UnionBase where + liftAllSymsS fa (UnionSingle v) = fa v + liftAllSymsS fa (UnionIf _ _ c t f) = + \l -> SomeSym c : (liftAllSymsS fa t . liftAllSymsS fa f $ l) + +-- | Fully reconstruct a 'Grisette.Core.Union' to maintain the merged invariant. +fullReconstruct :: MergingStrategy a -> UnionBase a -> UnionBase a +fullReconstruct strategy (UnionIf _ False cond t f) = + ifWithStrategyInv + strategy + cond + (fullReconstruct strategy t) + (fullReconstruct strategy f) +fullReconstruct _ u = u +{-# INLINE fullReconstruct #-} + +-- | Use a specific strategy to build a 'UnionIf' value. +-- +-- The merged invariant will be maintained in the result. +ifWithStrategy :: + MergingStrategy a -> + SymBool -> + UnionBase a -> + UnionBase a -> + UnionBase a +ifWithStrategy strategy cond t@(UnionIf _ False _ _ _) f = + ifWithStrategy strategy cond (fullReconstruct strategy t) f +ifWithStrategy strategy cond t f@(UnionIf _ False _ _ _) = + ifWithStrategy strategy cond t (fullReconstruct strategy f) +ifWithStrategy strategy cond t f = ifWithStrategyInv strategy cond t f +{-# INLINE ifWithStrategy #-} + +ifWithStrategyInv :: + MergingStrategy a -> + SymBool -> + UnionBase a -> + UnionBase a -> + UnionBase a +ifWithStrategyInv _ (Con v) t f + | v = t + | otherwise = f +ifWithStrategyInv strategy cond (UnionIf _ True condTrue tt _) f + | cond == condTrue = ifWithStrategyInv strategy cond tt f +-- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond ft f +ifWithStrategyInv strategy cond t (UnionIf _ True condFalse _ ff) + | cond == condFalse = ifWithStrategyInv strategy cond t ff +-- {| symNot cond == condTrue || cond == symNot condTrue = ifWithStrategyInv strategy cond t tf -- buggy here condTrue +ifWithStrategyInv (SimpleStrategy m) cond (UnionSingle l) (UnionSingle r) = + UnionSingle $ m cond l r +ifWithStrategyInv + strategy@(SortedStrategy idxFun substrategy) + cond + ifTrue + ifFalse = case (ifTrue, ifFalse) of + (UnionSingle _, UnionSingle _) -> ssUnionIf cond ifTrue ifFalse + (UnionSingle _, UnionIf {}) -> sgUnionIf cond ifTrue ifFalse + (UnionIf {}, UnionSingle _) -> gsUnionIf cond ifTrue ifFalse + _ -> ggUnionIf cond ifTrue ifFalse + where + ssUnionIf cond' ifTrue' ifFalse' + | idxt < idxf = ifWithLeftMost True cond' ifTrue' ifFalse' + | idxt == idxf = + ifWithStrategyInv (substrategy idxt) cond' ifTrue' ifFalse' + | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' + where + idxt = idxFun $ leftMost ifTrue' + idxf = idxFun $ leftMost ifFalse' + {-# INLINE ssUnionIf #-} + sgUnionIf cond' ifTrue' ifFalse'@(UnionIf _ True condf ft ff) + | idxft == idxff = ssUnionIf cond' ifTrue' ifFalse' + | idxt < idxft = ifWithLeftMost True cond' ifTrue' ifFalse' + | idxt == idxft = + ifWithLeftMost + True + (cond' .|| condf) + (ifWithStrategyInv (substrategy idxt) cond' ifTrue' ft) + ff + | otherwise = + ifWithLeftMost + True + (symNot cond' .&& condf) + ft + (ifWithStrategyInv strategy cond' ifTrue' ff) + where + idxft = idxFun $ leftMost ft + idxff = idxFun $ leftMost ff + idxt = idxFun $ leftMost ifTrue' + sgUnionIf _ _ _ = undefined + {-# INLINE sgUnionIf #-} + gsUnionIf cond' ifTrue'@(UnionIf _ True condt tt tf) ifFalse' + | idxtt == idxtf = ssUnionIf cond' ifTrue' ifFalse' + | idxtt < idxf = + ifWithLeftMost True (cond' .&& condt) tt $ + ifWithStrategyInv strategy cond' tf ifFalse' + | idxtt == idxf = + ifWithLeftMost + True + (symNot cond' .|| condt) + (ifWithStrategyInv (substrategy idxf) cond' tt ifFalse') + tf + | otherwise = ifWithLeftMost True (symNot cond') ifFalse' ifTrue' + where + idxtt = idxFun $ leftMost tt + idxtf = idxFun $ leftMost tf + idxf = idxFun $ leftMost ifFalse' + gsUnionIf _ _ _ = undefined + {-# INLINE gsUnionIf #-} + ggUnionIf + cond' + ifTrue'@(UnionIf _ True condt tt tf) + ifFalse'@(UnionIf _ True condf ft ff) + | idxtt == idxtf = sgUnionIf cond' ifTrue' ifFalse' + | idxft == idxff = gsUnionIf cond' ifTrue' ifFalse' + | idxtt < idxft = + ifWithLeftMost True (cond' .&& condt) tt $ + ifWithStrategyInv strategy cond' tf ifFalse' + | idxtt == idxft = + let newCond = symIte cond' condt condf + newUnionIfTrue = + ifWithStrategyInv (substrategy idxtt) cond' tt ft + newUnionIfFalse = ifWithStrategyInv strategy cond' tf ff + in ifWithLeftMost True newCond newUnionIfTrue newUnionIfFalse + | otherwise = + ifWithLeftMost True (symNot cond' .&& condf) ft $ + ifWithStrategyInv strategy cond' ifTrue' ff + where + idxtt = idxFun $ leftMost tt + idxtf = idxFun $ leftMost tf + idxft = idxFun $ leftMost ft + idxff = idxFun $ leftMost ff + ggUnionIf _ _ _ = undefined + {-# INLINE ggUnionIf #-} +ifWithStrategyInv NoStrategy cond ifTrue ifFalse = + ifWithLeftMost True cond ifTrue ifFalse +ifWithStrategyInv _ _ _ _ = error "Invariant violated" +{-# INLINE ifWithStrategyInv #-} diff --git a/src/Grisette/Internal/Core/TH/MergeConstructor.hs b/src/Grisette/Internal/Core/TH/MergeConstructor.hs deleted file mode 100644 --- a/src/Grisette/Internal/Core/TH/MergeConstructor.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE TemplateHaskellQuotes #-} -{-# LANGUAGE Trustworthy #-} - --- | --- Module : Grisette.Internal.Core.TH.MergedConstructor --- Copyright : (c) Sirui Lu 2021-2024 --- License : BSD-3-Clause (see the LICENSE file) --- --- Maintainer : siruilu@cs.washington.edu --- Stability : Experimental --- Portability : GHC only -module Grisette.Internal.Core.TH.MergeConstructor - ( mkMergeConstructor, - mkMergeConstructor', - ) -where - -import Control.Monad (join, replicateM, when, zipWithM) -import Data.Bifunctor (Bifunctor (second)) -import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) -import Language.Haskell.TH - ( Body (NormalB), - Clause (Clause), - Con (ForallC, GadtC, InfixC, NormalC, RecC, RecGadtC), - Dec (DataD, FunD, NewtypeD, SigD), - Exp (AppE, ConE, LamE, VarE), - Info (DataConI, TyConI), - Name, - Pat (VarP), - Pred, - Q, - TyVarBndr (PlainTV), - Type (AppT, ArrowT, ForallT, VarT), - mkName, - newName, - pprint, - reify, - ) -#if MIN_VERSION_template_haskell(2,17,0) -import Language.Haskell.TH.Syntax - ( Name (Name), - OccName (OccName), - Specificity (SpecifiedSpec), - Type (MulArrowT), - ) -#else -import Language.Haskell.TH.Syntax (Name (Name), OccName (OccName)) -#endif - --- | Generate constructor wrappers that wraps the result in a container with `TryMerge` with provided names. --- --- > mkMergeConstructor' ["mrgTuple2"] ''(,) --- --- generates --- --- > mrgTuple2 :: (Mergeable (a, b), Applicative m, TryMerge m) => a -> b -> u (a, b) --- > mrgTuple2 = \v1 v2 -> mrgSingle (v1, v2) -mkMergeConstructor' :: - -- | Names for generated wrappers - [String] -> - -- | The type to generate the wrappers for - Name -> - Q [Dec] -mkMergeConstructor' names typName = do - constructors <- getConstructors typName - when (length names /= length constructors) $ - fail "Number of names does not match the number of constructors" - ds <- zipWithM mkSingleWrapper names constructors - return $ join ds - -occName :: Name -> String -occName (Name (OccName name) _) = name - -getConstructorName :: Con -> Q String -getConstructorName (NormalC name _) = return $ occName name -getConstructorName (RecC name _) = return $ occName name -getConstructorName InfixC {} = - fail "You should use mkMergeConstructor' to manually provide the name for infix constructors" -getConstructorName (ForallC _ _ c) = getConstructorName c -getConstructorName (GadtC [name] _ _) = return $ occName name -getConstructorName (RecGadtC [name] _ _) = return $ occName name -getConstructorName c = fail $ "Unsupported constructor at this time: " ++ pprint c - -getConstructors :: Name -> Q [Con] -getConstructors typName = do - d <- reify typName - case d of - TyConI (DataD _ _ _ _ constructors _) -> return constructors - TyConI (NewtypeD _ _ _ _ constructor _) -> return [constructor] - _ -> fail $ "Unsupported declaration: " ++ pprint d - --- | Generate constructor wrappers that wraps the result in a container with `TryMerge`. --- --- > mkMergeConstructor "mrg" ''Maybe --- --- generates --- --- > mrgJust :: (Mergeable (Maybe a), Applicative m, TryMerge m) => m (Maybe a) --- > mrgNothing = mrgSingle Nothing --- > mrgJust :: (Mergeable (Maybe a), Applicative m, TryMerge m) => a -> m (Maybe a) --- > mrgJust = \x -> mrgSingle (Just x) -mkMergeConstructor :: - -- | Prefix for generated wrappers - String -> - -- | The type to generate the wrappers for - Name -> - Q [Dec] -mkMergeConstructor prefix typName = do - constructors <- getConstructors typName - constructorNames <- mapM getConstructorName constructors - mkMergeConstructor' ((prefix ++) <$> constructorNames) typName - -augmentNormalCExpr :: Int -> Exp -> Q Exp -augmentNormalCExpr n f = do - xs <- replicateM n (newName "x") - let args = map VarP xs - mrgSingleFun <- [|mrgSingle|] - return $ - LamE - args - ( AppE mrgSingleFun $ - foldl AppE f (map VarE xs) - ) - -#if MIN_VERSION_template_haskell(2,17,0) -augmentFinalType :: Type -> Q (([TyVarBndr Specificity], [Pred]), Type) -#else -augmentFinalType :: Type -> Q (([TyVarBndr], [Pred]), Type) -#endif -augmentFinalType (AppT a@(AppT ArrowT _) t) = do - tl <- augmentFinalType t - return $ second (AppT a) tl -#if MIN_VERSION_template_haskell(2,17,0) -augmentFinalType (AppT (AppT (AppT MulArrowT _) var) t) = do - tl <- augmentFinalType t - return $ second (AppT (AppT ArrowT var)) tl -#endif -augmentFinalType t = do - mName <- newName "m" - let mTy = VarT mName - mergeable <- [t|Mergeable|] - applicative <- [t|Applicative|] - tryMerge <- [t|TryMerge|] -#if MIN_VERSION_template_haskell(2,17,0) - return - ( ( [ PlainTV mName SpecifiedSpec ], - [ AppT mergeable t, AppT applicative mTy, AppT tryMerge mTy] - ), - AppT mTy t - ) -#else - return - ( ( [ PlainTV mName ], - [ AppT mergeable t, AppT applicative mTy, AppT tryMerge mTy] - ), - AppT mTy t - ) -#endif - -augmentNormalCType :: Type -> Q Type -augmentNormalCType (ForallT tybinders ctx ty1) = do - ((bndrs, preds), augmentedTyp) <- augmentFinalType ty1 - return $ ForallT (tybinders ++ bndrs) (preds ++ ctx) augmentedTyp -augmentNormalCType t = do - ((bndrs, preds), augmentedTyp) <- augmentFinalType t - return $ ForallT bndrs preds augmentedTyp - -mkSingleWrapper :: String -> Con -> Q [Dec] -mkSingleWrapper name (NormalC oriName b) = do - DataConI _ constructorTyp _ <- reify oriName - augmentedTyp <- augmentNormalCType constructorTyp - let retName = mkName name - expr <- augmentNormalCExpr (length b) (ConE oriName) - return - [ SigD retName augmentedTyp, - FunD retName [Clause [] (NormalB expr) []] - ] -mkSingleWrapper name (RecC oriName b) = do - DataConI _ constructorTyp _ <- reify oriName - augmentedTyp <- augmentNormalCType constructorTyp - let retName = mkName name - expr <- augmentNormalCExpr (length b) (ConE oriName) - return - [ SigD retName augmentedTyp, - FunD retName [Clause [] (NormalB expr) []] - ] -mkSingleWrapper _ v = fail $ "Unsupported constructor" ++ pprint v diff --git a/src/Grisette/Internal/SymPrim/AllSyms.hs b/src/Grisette/Internal/SymPrim/AllSyms.hs --- a/src/Grisette/Internal/SymPrim/AllSyms.hs +++ b/src/Grisette/Internal/SymPrim/AllSyms.hs @@ -6,9 +6,11 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -23,11 +25,22 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Internal.SymPrim.AllSyms - ( symSize, - symsSize, + ( -- * Get all symbolic primitive values in a value SomeSym (..), AllSyms (..), + AllSyms1 (..), + allSymsS1, + AllSyms2 (..), + allSymsS2, allSymsSize, + symSize, + symsSize, + + -- * Generic 'AllSyms' + AllSymsArgs (..), + GAllSyms (..), + genericAllSymsS, + genericLiftAllSymsS, ) where @@ -42,39 +55,89 @@ import qualified Data.ByteString as B import Data.Functor.Sum (Sum) import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) import qualified Data.Text as T import Data.Word (Word16, Word32, Word64, Word8) import GHC.Generics ( Generic (Rep, from), + Generic1 (Rep1, from1), K1 (K1), M1 (M1), + Par1 (Par1), + Rec1 (Rec1), U1, + V1, + (:.:) (Comp1), type (:*:) ((:*:)), type (:+:) (L1, R1), ) -import Generics.Deriving (Default (Default, unDefault)) +import GHC.TypeNats (KnownNat, type (<=)) +import Generics.Deriving + ( Default (Default, unDefault), + Default1 (Default1, unDefault1), + ) import Grisette.Internal.Core.Control.Exception ( AssertionError, VerificationConditions, ) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) import Grisette.Internal.SymPrim.Prim.SomeTerm ( SomeTerm (SomeTerm), ) import Grisette.Internal.SymPrim.Prim.Term ( LinkedRep (underlyingTerm), + pformat, ) import Grisette.Internal.SymPrim.Prim.TermUtils ( someTermsSize, termSize, termsSize, ) +import Grisette.Internal.TH.DeriveBuiltin (deriveBuiltins) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (ViaDefault, ViaDefault1), + ) +import Grisette.Internal.Utils.Derive (Arity0, Arity1) -- $setup -- >>> import Grisette.Core -- >>> import Grisette.SymPrim -- >>> import Grisette.Backend -- >>> import Data.Proxy +-- >>> :set -XOverloadedStrings +-- | Some symbolic value with 'LinkedRep' constraint. +data SomeSym where + SomeSym :: (LinkedRep con sym) => sym -> SomeSym + +instance Show SomeSym where + show (SomeSym s) = pformat $ underlyingTerm s + +-- | Extract all symbolic primitive values that are represented as SMT terms. +-- +-- >>> allSyms (["a" + 1 :: SymInteger, -"b"], "c" :: SymBool) +-- [(+ 1 a),(- b),c] +-- +-- This is usually used for getting a statistical summary of the size of +-- a symbolic value with 'allSymsSize'. +-- +-- __Note:__ This type class can be derived for algebraic data types. You may +-- need the @DerivingVia@ and @DerivingStrategies@ extenstions. +-- +-- > data X = ... deriving Generic deriving AllSyms via (Default X) +class AllSyms a where + -- | Convert a value to a list of symbolic primitive values. It should + -- prepend to an existing list of symbolic primitive values. + allSymsS :: a -> [SomeSym] -> [SomeSym] + allSymsS a l = allSyms a ++ l + + -- | Specialized 'allSymsS' that prepends to an empty list. + allSyms :: a -> [SomeSym] + allSyms a = allSymsS a [] + + {-# MINIMAL allSymsS | allSyms #-} + -- | Get the sum of the sizes of a list of symbolic terms. -- Duplicate sub-terms are counted for only once. -- @@ -99,10 +162,6 @@ symSize = termSize . underlyingTerm @con {-# INLINE symSize #-} --- | Some symbolic value with 'LinkedRep' constraint. -data SomeSym where - SomeSym :: (LinkedRep con sym) => sym -> SomeSym - someUnderlyingTerm :: SomeSym -> SomeTerm someUnderlyingTerm (SomeSym s) = SomeTerm $ underlyingTerm s @@ -110,220 +169,299 @@ someSymsSize = someTermsSize . fmap someUnderlyingTerm {-# INLINE someSymsSize #-} --- | Extract all symbolic primitive values that are represented as SMT terms. --- --- __Note:__ This type class can be derived for algebraic data types. You may --- need the @DerivingVia@ and @DerivingStrategies@ extenstions. --- --- > data X = ... deriving Generic deriving AllSyms via (Default X) -class AllSyms a where - -- | Convert a value to a list of symbolic primitive values. It should - -- prepend to an existing list of symbolic primitive values. - allSymsS :: a -> [SomeSym] -> [SomeSym] - allSymsS a l = allSyms a ++ l - - -- | Specialized 'allSymsS' that prepends to an empty list. - allSyms :: a -> [SomeSym] - allSyms a = allSymsS a [] - - {-# MINIMAL allSymsS | allSyms #-} - -- | Get the total size of symbolic terms in a value. -- Duplicate sub-terms are counted for only once. -- -- >>> allSymsSize ("a" :: SymInteger, "a" + "b" :: SymInteger, ("a" + "b") * "c" :: SymInteger) -- 5 +-- +-- The 5 terms are @a@, @b@, @(+ a b)@, @c@, and @(* (+ a b) c)@. allSymsSize :: (AllSyms a) => a -> Int allSymsSize = someSymsSize . allSyms -class AllSyms' a where - allSymsS' :: a c -> [SomeSym] -> [SomeSym] +-- | Lifting of the 'AllSyms' class to unary type constructors. +class (forall a. (AllSyms a) => AllSyms (f a)) => AllSyms1 f where + -- | Lift the 'allSymsS' function to unary type constructors. + liftAllSymsS :: (a -> [SomeSym] -> [SomeSym]) -> f a -> [SomeSym] -> [SomeSym] -instance (Generic a, AllSyms' (Rep a)) => AllSyms (Default a) where - allSymsS = allSymsS' . from . unDefault +-- | Lift the standard 'allSymsS' function to unary type constructors. +allSymsS1 :: (AllSyms1 f, AllSyms a) => f a -> [SomeSym] -> [SomeSym] +allSymsS1 = liftAllSymsS allSymsS +{-# INLINE allSymsS1 #-} -instance AllSyms' U1 where - allSymsS' _ = id +-- | Lifting of the 'AllSyms' class to binary type constructors. +class (forall a. (AllSyms a) => AllSyms1 (f a)) => AllSyms2 f where + -- | Lift the 'allSymsS' function to binary type constructors. + liftAllSymsS2 :: + (a -> [SomeSym] -> [SomeSym]) -> + (b -> [SomeSym] -> [SomeSym]) -> + f a b -> + [SomeSym] -> + [SomeSym] -instance (AllSyms c) => AllSyms' (K1 i c) where - allSymsS' (K1 v) = allSymsS v +-- | Lift the standard 'allSymsS' function to binary type constructors. +allSymsS2 :: + (AllSyms2 f, AllSyms a, AllSyms b) => f a b -> [SomeSym] -> [SomeSym] +allSymsS2 = liftAllSymsS2 allSymsS allSymsS +{-# INLINE allSymsS2 #-} -instance (AllSyms' a) => AllSyms' (M1 i c a) where - allSymsS' (M1 v) = allSymsS' v +-- Derivation -instance (AllSyms' a, AllSyms' b) => AllSyms' (a :+: b) where - allSymsS' (L1 l) = allSymsS' l - allSymsS' (R1 r) = allSymsS' r +-- | The arguments to the generic 'AllSyms' function. +data family AllSymsArgs arity a :: Type -instance (AllSyms' a, AllSyms' b) => AllSyms' (a :*: b) where - allSymsS' (a :*: b) = allSymsS' a . allSymsS' b +data instance AllSymsArgs Arity0 _ = AllSymsArgs0 -#define CONCRETE_ALLSYMS(type) \ -instance AllSyms type where \ - allSymsS _ = id +newtype instance AllSymsArgs Arity1 a + = AllSymsArgs1 (a -> [SomeSym] -> [SomeSym]) -#if 1 -CONCRETE_ALLSYMS(Bool) -CONCRETE_ALLSYMS(Integer) -CONCRETE_ALLSYMS(Char) -CONCRETE_ALLSYMS(Int) -CONCRETE_ALLSYMS(Int8) -CONCRETE_ALLSYMS(Int16) -CONCRETE_ALLSYMS(Int32) -CONCRETE_ALLSYMS(Int64) -CONCRETE_ALLSYMS(Word) -CONCRETE_ALLSYMS(Word8) -CONCRETE_ALLSYMS(Word16) -CONCRETE_ALLSYMS(Word32) -CONCRETE_ALLSYMS(Word64) -CONCRETE_ALLSYMS(B.ByteString) -CONCRETE_ALLSYMS(T.Text) -#endif +-- | The class of types that can generically extract all symbolic primitives. +class GAllSyms arity f where + gallSymsS :: AllSymsArgs arity a -> f a -> [SomeSym] -> [SomeSym] -instance AllSyms () where - allSymsS _ = id +instance GAllSyms arity V1 where + gallSymsS _ _ = id --- Either -deriving via - (Default (Either a b)) - instance - ( AllSyms a, - AllSyms b - ) => - AllSyms (Either a b) +instance GAllSyms arity U1 where + gallSymsS _ _ = id --- Maybe -deriving via (Default (Maybe a)) instance (AllSyms a) => AllSyms (Maybe a) +instance (AllSyms c) => GAllSyms arity (K1 i c) where + gallSymsS _ (K1 x) = allSymsS x --- List -deriving via (Default [a]) instance (AllSyms a) => AllSyms [a] +instance (GAllSyms arity a) => GAllSyms arity (M1 i c a) where + gallSymsS args (M1 x) = gallSymsS args x --- (,) -deriving via - (Default (a, b)) - instance - (AllSyms a, AllSyms b) => - AllSyms (a, b) +instance (GAllSyms arity a, GAllSyms arity b) => GAllSyms arity (a :+: b) where + gallSymsS args (L1 l) = gallSymsS args l + gallSymsS args (R1 r) = gallSymsS args r --- (,,) -deriving via - (Default (a, b, c)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c - ) => - AllSyms (a, b, c) +instance (GAllSyms arity a, GAllSyms arity b) => GAllSyms arity (a :*: b) where + gallSymsS args (a :*: b) = gallSymsS args a . gallSymsS args b --- (,,,) -deriving via - (Default (a, b, c, d)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d - ) => - AllSyms (a, b, c, d) +instance GAllSyms Arity1 Par1 where + gallSymsS (AllSymsArgs1 f) (Par1 x) = f x --- (,,,,) -deriving via - (Default (a, b, c, d, e)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d, - AllSyms e - ) => - AllSyms (a, b, c, d, e) +instance (AllSyms1 f) => GAllSyms Arity1 (Rec1 f) where + gallSymsS (AllSymsArgs1 f) (Rec1 x) = liftAllSymsS f x --- (,,,,,) -deriving via - (Default (a, b, c, d, e, f)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d, - AllSyms e, - AllSyms f - ) => - AllSyms (a, b, c, d, e, f) +instance (AllSyms1 f, GAllSyms Arity1 g) => GAllSyms Arity1 (f :.: g) where + gallSymsS targs (Comp1 x) = liftAllSymsS (gallSymsS targs) x --- (,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d, - AllSyms e, - AllSyms f, - AllSyms g - ) => - AllSyms (a, b, c, d, e, f, g) +-- | Generic 'allSymsS' function. +genericAllSymsS :: + (Generic a, GAllSyms Arity0 (Rep a)) => + a -> + [SomeSym] -> + [SomeSym] +genericAllSymsS x = gallSymsS AllSymsArgs0 (from x) +{-# INLINE genericAllSymsS #-} --- (,,,,,,,) -deriving via - (Default (a, b, c, d, e, f, g, h)) - instance - ( AllSyms a, - AllSyms b, - AllSyms c, - AllSyms d, - AllSyms e, - AllSyms f, - AllSyms g, - AllSyms h - ) => - AllSyms ((,,,,,,,) a b c d e f g h) +-- | Generic 'liftAllSymsS' function. +genericLiftAllSymsS :: + (Generic1 f, GAllSyms Arity1 (Rep1 f)) => + (a -> [SomeSym] -> [SomeSym]) -> + f a -> + [SomeSym] -> + [SomeSym] +genericLiftAllSymsS f x = gallSymsS (AllSymsArgs1 f) (from1 x) +{-# INLINE genericLiftAllSymsS #-} --- MaybeT +instance (Generic a, GAllSyms Arity0 (Rep a)) => AllSyms (Default a) where + allSymsS = genericAllSymsS . unDefault + {-# INLINE allSymsS #-} + instance - (AllSyms (m (Maybe a))) => - AllSyms (MaybeT m a) + (Generic1 f, GAllSyms Arity1 (Rep1 f), AllSyms a) => + AllSyms (Default1 f a) where - allSymsS (MaybeT v) = allSymsS v + allSymsS = allSymsS1 + {-# INLINE allSymsS #-} +instance (Generic1 f, GAllSyms Arity1 (Rep1 f)) => AllSyms1 (Default1 f) where + liftAllSymsS f = genericLiftAllSymsS f . unDefault1 + {-# INLINE liftAllSymsS #-} + +-- Instances +deriveBuiltins + (ViaDefault ''AllSyms) + [''AllSyms] + [ ''[], + ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''Identity + ] + +deriveBuiltins + (ViaDefault1 ''AllSyms1) + [''AllSyms, ''AllSyms1] + [ ''[], + ''Maybe, + ''Either, + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Identity + ] + -- ExceptT instance - (AllSyms (m (Either e a))) => + (AllSyms1 m, AllSyms e, AllSyms a) => AllSyms (ExceptT e m a) where - allSymsS (ExceptT v) = allSymsS v + allSymsS = allSymsS1 + {-# INLINE allSymsS #-} --- Sum -deriving via - (Default (Sum f g a)) - instance - (AllSyms (f a), AllSyms (g a)) => - AllSyms (Sum f g a) +instance + (AllSyms1 m, AllSyms e) => + AllSyms1 (ExceptT e m) + where + liftAllSymsS f (ExceptT v) = liftAllSymsS (liftAllSymsS f) v + {-# INLINE liftAllSymsS #-} +-- MaybeT +instance (AllSyms1 m, AllSyms a) => AllSyms (MaybeT m a) where + allSymsS = allSymsS1 + {-# INLINE allSymsS #-} + +instance (AllSyms1 m) => AllSyms1 (MaybeT m) where + liftAllSymsS f (MaybeT v) = liftAllSymsS (liftAllSymsS f) v + {-# INLINE liftAllSymsS #-} + -- WriterT instance - (AllSyms (m (a, s))) => + (AllSyms1 m, AllSyms a, AllSyms s) => AllSyms (WriterLazy.WriterT s m a) where - allSymsS (WriterLazy.WriterT v) = allSymsS v + allSymsS = allSymsS1 + {-# INLINE allSymsS #-} instance - (AllSyms (m (a, s))) => + (AllSyms1 m, AllSyms s) => + AllSyms1 (WriterLazy.WriterT s m) + where + liftAllSymsS f (WriterLazy.WriterT v) = + liftAllSymsS (liftAllSymsS2 f allSymsS) v + {-# INLINE liftAllSymsS #-} + +instance + (AllSyms1 m, AllSyms a, AllSyms s) => AllSyms (WriterStrict.WriterT s m a) where - allSymsS (WriterStrict.WriterT v) = allSymsS v + allSymsS = allSymsS1 + {-# INLINE allSymsS #-} --- Identity -instance (AllSyms a) => AllSyms (Identity a) where - allSymsS (Identity a) = allSymsS a +instance + (AllSyms1 m, AllSyms s) => + AllSyms1 (WriterStrict.WriterT s m) + where + liftAllSymsS f (WriterStrict.WriterT v) = + liftAllSymsS (liftAllSymsS2 f allSymsS) v + {-# INLINE liftAllSymsS #-} +-- Sum +deriving via + (Default (Sum f g a)) + instance + (AllSyms (f a), AllSyms (g a)) => + AllSyms (Sum f g a) + +deriving via + (Default1 (Sum f g)) + instance + (AllSyms1 f, AllSyms1 g) => + AllSyms1 (Sum f g) + -- IdentityT -instance (AllSyms (m a)) => AllSyms (IdentityT m a) where - allSymsS (IdentityT a) = allSymsS a +instance + (AllSyms1 m, AllSyms a) => + AllSyms (IdentityT m a) + where + allSymsS = allSymsS1 + {-# INLINE allSymsS #-} --- VerificationConditions -deriving via (Default VerificationConditions) instance AllSyms VerificationConditions +instance (AllSyms1 m) => AllSyms1 (IdentityT m) where + liftAllSymsS f (IdentityT a) = liftAllSymsS f a + {-# INLINE liftAllSymsS #-} --- AssertionError -deriving via (Default AssertionError) instance AllSyms AssertionError +-- AllSyms2 +instance AllSyms2 Either where + liftAllSymsS2 f _ (Left x) = f x + liftAllSymsS2 _ g (Right y) = g y + {-# INLINE liftAllSymsS2 #-} + +instance AllSyms2 (,) where + liftAllSymsS2 f g (x, y) = f x . g y + {-# INLINE liftAllSymsS2 #-} + +instance (AllSyms a) => AllSyms2 ((,,) a) where + liftAllSymsS2 f g (x, y, z) = allSymsS x . f y . g z + {-# INLINE liftAllSymsS2 #-} + +instance (AllSyms a, AllSyms b) => AllSyms2 ((,,,) a b) where + liftAllSymsS2 f g (x, y, z, w) = allSymsS x . allSymsS y . f z . g w + {-# INLINE liftAllSymsS2 #-} + +#define CONCRETE_ALLSYMS(type) \ +instance AllSyms type where \ + allSymsS _ = id; \ + {-# INLINE allSymsS #-} + +#define CONCRETE_ALLSYMS_BV(type) \ +instance (KnownNat n, 1 <= n) => AllSyms (type n) where \ + allSymsS _ = id; \ + {-# INLINE allSymsS #-} + +#if 1 +CONCRETE_ALLSYMS(Bool) +CONCRETE_ALLSYMS(Integer) +CONCRETE_ALLSYMS(Char) +CONCRETE_ALLSYMS(Int) +CONCRETE_ALLSYMS(Int8) +CONCRETE_ALLSYMS(Int16) +CONCRETE_ALLSYMS(Int32) +CONCRETE_ALLSYMS(Int64) +CONCRETE_ALLSYMS(Word) +CONCRETE_ALLSYMS(Word8) +CONCRETE_ALLSYMS(Word16) +CONCRETE_ALLSYMS(Word32) +CONCRETE_ALLSYMS(Word64) +CONCRETE_ALLSYMS(Float) +CONCRETE_ALLSYMS(Double) +CONCRETE_ALLSYMS(B.ByteString) +CONCRETE_ALLSYMS(T.Text) +CONCRETE_ALLSYMS(FPRoundingMode) +CONCRETE_ALLSYMS_BV(WordN) +CONCRETE_ALLSYMS_BV(IntN) +#endif + +instance (ValidFP eb sb) => AllSyms (FP eb sb) where + allSymsS _ = id + {-# INLINE allSymsS #-} diff --git a/src/Grisette/Internal/SymPrim/BV.hs b/src/Grisette/Internal/SymPrim/BV.hs --- a/src/Grisette/Internal/SymPrim/BV.hs +++ b/src/Grisette/Internal/SymPrim/BV.hs @@ -130,6 +130,14 @@ import Text.Read (lift) import qualified Text.Read.Lex as L +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + +-- | An exception that would be thrown when operations are performed on +-- incompatible bit widths. data BitwidthMismatch = BitwidthMismatch deriving (Show, Eq, Ord, Generic) @@ -137,16 +145,34 @@ displayException BitwidthMismatch = "Bit width does not match" -- | --- Symbolic unsigned bit vectors. +-- Unsigned bit vector type. Indexed with the bit width. Signedness affect the +-- semantics of the operations, including comparison/extension, etc. +-- +-- >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals +-- >>> 3 + 5 :: WordN 5 +-- 0b01000 +-- >>> sizedBVConcat (0b101 :: WordN 3) (0b110 :: WordN 3) +-- 0b101110 +-- >>> sizedBVExt (Proxy @6) (0b101 :: WordN 3) +-- 0b000101 +-- >>> (8 :: WordN 4) < (7 :: WordN 4) +-- False +-- +-- More operations are available. Please refer to "Grisette.Core#g:symops" for +-- more information. newtype WordN (n :: Nat) = WordN {unWordN :: Integer} deriving (Eq, Ord, Generic, Lift, Hashable, NFData) +-- | 8-bit unsigned bit-vector type WordN8 = WordN 8 +-- | 16-bit unsigned bit-vector type WordN16 = WordN 16 +-- | 32-bit unsigned bit-vector type WordN32 = WordN 32 +-- | 64-bit unsigned bit-vector type WordN64 = WordN 64 instance (KnownNat n, 1 <= n) => Show (WordN n) where @@ -187,16 +213,34 @@ readList = readListDefault -- | --- Symbolic signed bit vectors. +-- Signed bit vector type. Indexed with the bit width. Signedness affects the +-- semantics of the operations, including comparison/extension, etc. +-- +-- >>> :set -XOverloadedStrings -XDataKinds -XBinaryLiterals +-- >>> 3 + 5 :: IntN 5 +-- 0b01000 +-- >>> sizedBVConcat (0b101 :: IntN 3) (0b110 :: IntN 3) +-- 0b101110 +-- >>> sizedBVExt (Proxy @6) (0b101 :: IntN 3) +-- 0b111101 +-- >>> (8 :: IntN 4) < (7 :: IntN 4) +-- True +-- +-- More operations are available. Please refer to "Grisette.Core#g:symops" for +-- more information. newtype IntN (n :: Nat) = IntN {unIntN :: Integer} deriving (Eq, Generic, Lift, Hashable, NFData) +-- | 8-bit signed bit-vector type IntN8 = IntN 8 +-- | 16-bit signed bit-vector type IntN16 = IntN 16 +-- | 32-bit signed bit-vector type IntN32 = IntN 32 +-- | 64-bit signed bit-vector type IntN64 = IntN 64 instance (KnownNat n, 1 <= n) => Show (IntN n) where diff --git a/src/Grisette/Internal/SymPrim/FP.hs b/src/Grisette/Internal/SymPrim/FP.hs --- a/src/Grisette/Internal/SymPrim/FP.hs +++ b/src/Grisette/Internal/SymPrim/FP.hs @@ -18,11 +18,18 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE UndecidableInstances #-} {- HLINT ignore "Unused LANGUAGE pragma" -} +-- | +-- Module : Grisette.Internal.SymPrim.FP +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Internal.SymPrim.FP ( ValidFP, FP (..), @@ -73,6 +80,12 @@ import Test.QuickCheck (frequency, oneof) import qualified Test.QuickCheck as QC +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + bvIsNonZeroFromGEq1 :: forall w r proxy. (1 <= w) => @@ -88,6 +101,13 @@ -- | IEEE 754 floating-point number with @eb@ exponent bits and @sb@ significand -- bits. +-- +-- >>> :set -XDataKinds +-- >>> 1.0 + 2.0 :: FP 11 53 +-- 3.0 +-- +-- More operations are available. Please refer to "Grisette.Core#g:symops" for +-- more information. newtype FP (eb :: Nat) (sb :: Nat) = FP {unFP :: FloatingPoint eb sb} deriving newtype (Eq, Show) @@ -257,10 +277,29 @@ oneof [return 0, return $ 1 `shiftL` (sb - 1)] :: QC.Gen (WordN (eb + sb)) -data FPRoundingMode = RNE | RNA | RTP | RTN | RTZ - deriving (Eq, Ord, Show, Generic, Lift) +-- | Rounding mode for floating-point operations. +data FPRoundingMode + = -- | Round to nearest, ties to even. + RNE + | -- | Round to nearest, ties to away from zero. + RNA + | -- | Round towards positive infinity. + RTP + | -- | Round towards negative infinity. + RTN + | -- | Round towards zero. + RTZ + deriving (Eq, Ord, Generic, Lift) deriving anyclass (Hashable, NFData) +instance Show FPRoundingMode where + show RNE = "rne" + show RNA = "rna" + show RTP = "rtp" + show RTN = "rtn" + show RTZ = "rtz" + +-- | All IEEE 754 rounding modes. allFPRoundingMode :: [FPRoundingMode] allFPRoundingMode = [RNE, RNA, RTP, RTN, RTZ] diff --git a/src/Grisette/Internal/SymPrim/GeneralFun.hs b/src/Grisette/Internal/SymPrim/GeneralFun.hs --- a/src/Grisette/Internal/SymPrim/GeneralFun.hs +++ b/src/Grisette/Internal/SymPrim/GeneralFun.hs @@ -196,6 +196,7 @@ infixr 0 --> +-- | Build a general symbolic function with a bounded symbol and a term. buildGeneralFun :: (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term b -> a --> b buildGeneralFun arg v = @@ -640,6 +641,7 @@ sbvApplyTerm p f a = withPrim @(a --> b) p $ withNonFuncPrim @a p $ f a +-- | Substitute a term for a symbol in a term. substTerm :: forall a b. (SupportedPrim a, SupportedPrim b) => TypedSymbol a -> Term a -> Term b -> Term b substTerm sym term = gov where diff --git a/src/Grisette/Internal/SymPrim/IntBitwidth.hs b/src/Grisette/Internal/SymPrim/IntBitwidth.hs --- a/src/Grisette/Internal/SymPrim/IntBitwidth.hs +++ b/src/Grisette/Internal/SymPrim/IntBitwidth.hs @@ -11,5 +11,7 @@ import Data.Bits (FiniteBits (finiteBitSize)) import Language.Haskell.TH (TyLit (NumTyLit), Type (LitT), TypeQ) +-- | Get the bitwidth of 'Int'. intBitwidthQ :: TypeQ -intBitwidthQ = return $ LitT (NumTyLit $ toInteger $ finiteBitSize (undefined :: Int)) +intBitwidthQ = + return $ LitT (NumTyLit $ toInteger $ finiteBitSize (undefined :: Int)) diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Caches.hs @@ -42,6 +42,9 @@ termCacheCell = unsafePerformIO $ mkOnceIO $ newIORef M.empty {-# NOINLINE termCacheCell #-} +-- | Internal cache for memoization of term construction. Different types have +-- different caches and they may share names, ids, or representations, but they +-- are not the same term. typeMemoizedCache :: forall a. (Interned a, Typeable a) => Cache a typeMemoizedCache = unsafeDupablePerformIO $ do c <- termCacheCell diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Instances/PEvalFP.hs @@ -156,7 +156,7 @@ {-# INLINE sbvFPBinaryTerm #-} pevalFPRoundingUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => + (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => FPRoundingUnaryOp -> Term FPRoundingMode -> Term (FP eb sb) -> @@ -175,7 +175,7 @@ {-# INLINE sbvFPRoundingUnaryTerm #-} pevalFPRoundingBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => + (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => FPRoundingBinaryOp -> Term FPRoundingMode -> Term (FP eb sb) -> diff --git a/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs b/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs --- a/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Internal/Term.hs @@ -348,8 +348,8 @@ type PrimConstraint (n :: Nat) t :: Constraint type PrimConstraint _ _ = () --- | Indicates that a type is supported and can be represented as a symbolic --- term. +-- | Indicates that a type is supported, can be represented as a symbolic term, +-- and can be lowered to an SBV term. class ( Lift t, Typeable t, @@ -879,7 +879,7 @@ -- same symbol bodies with different types are considered different symbols -- and can coexist in a term. -- --- Simple symbols can be created with the 'OverloadedStrings' extension: +-- Simple symbols can be created with the @OverloadedStrings@ extension: -- -- >>> :set -XOverloadedStrings -- >>> "a" :: TypedSymbol Bool @@ -914,6 +914,7 @@ withSymbolSupported :: TypedSymbol t -> ((SupportedPrim t) => a) -> a withSymbolSupported (TypedSymbol _) a = a +-- | A non-index symbol. Type information are checked at runtime. data SomeTypedSymbol where SomeTypedSymbol :: forall t. TypeRep t -> TypedSymbol t -> SomeTypedSymbol @@ -1229,14 +1230,14 @@ !(Term (FP eb sb)) -> Term (FP eb sb) FPRoundingUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => + (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => {-# UNPACK #-} !Id -> !FPRoundingUnaryOp -> !(Term FPRoundingMode) -> !(Term (FP eb sb)) -> Term (FP eb sb) FPRoundingBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => + (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => {-# UNPACK #-} !Id -> !FPRoundingBinaryOp -> !(Term FPRoundingMode) -> @@ -1393,11 +1394,11 @@ pformat (SqrtTerm _ arg) = "(sqrt " ++ pformat arg ++ ")" pformat (FPUnaryTerm _ op arg) = "(" ++ show op ++ " " ++ pformat arg ++ ")" pformat (FPBinaryTerm _ op arg1 arg2) = "(" ++ show op ++ " " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" -pformat (FPRoundingUnaryTerm _ op mode arg) = "(" ++ show op ++ " " ++ show mode ++ " " ++ pformat arg ++ ")" +pformat (FPRoundingUnaryTerm _ op mode arg) = "(" ++ show op ++ " " ++ pformat mode ++ " " ++ pformat arg ++ ")" pformat (FPRoundingBinaryTerm _ op mode arg1 arg2) = - "(" ++ show op ++ " " ++ show mode ++ " " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" + "(" ++ show op ++ " " ++ pformat mode ++ " " ++ pformat arg1 ++ " " ++ pformat arg2 ++ ")" pformat (FPFMATerm _ mode arg1 arg2 arg3) = - "(fp.fma " ++ show mode ++ " " ++ pformat arg1 ++ " " ++ pformat arg2 ++ " " ++ pformat arg3 ++ ")" + "(fp.fma " ++ pformat mode ++ " " ++ pformat arg1 ++ " " ++ pformat arg2 ++ " " ++ pformat arg3 ++ ")" {-# INLINE pformat #-} instance NFData (Term a) where @@ -1705,13 +1706,13 @@ !(Term (FP eb sb)) -> UTerm (FP eb sb) UFPRoundingUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => + (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => !FPRoundingUnaryOp -> !(Term FPRoundingMode) -> !(Term (FP eb sb)) -> UTerm (FP eb sb) UFPRoundingBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => + (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => !FPRoundingBinaryOp -> !(Term FPRoundingMode) -> !(Term (FP eb sb)) -> @@ -2313,7 +2314,7 @@ fpBinaryTerm op l r = internTerm $ UFPBinaryTerm op l r fpRoundingUnaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => + (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => FPRoundingUnaryOp -> Term FPRoundingMode -> Term (FP eb sb) -> @@ -2321,7 +2322,7 @@ fpRoundingUnaryTerm op mode v = internTerm $ UFPRoundingUnaryTerm op mode v fpRoundingBinaryTerm :: - (ValidFP eb sb, SupportedPrim (FP eb sb)) => + (ValidFP eb sb, SupportedPrim (FP eb sb), SupportedPrim FPRoundingMode) => FPRoundingBinaryOp -> Term FPRoundingMode -> Term (FP eb sb) -> @@ -2464,6 +2465,10 @@ | orEqFirst r l2 = r | orEqTrue l1 r = pevalOrTerm l2 r | orEqTrue l2 r = pevalOrTerm l1 r +pevalOrTerm + (AndTerm _ nl1@(NotTerm _ l1) l2) + (EqTerm _ (Dyn (e1 :: Term Bool)) (Dyn (e2 :: Term Bool))) + | l1 == e1 && l2 == e2 = pevalOrTerm nl1 l2 pevalOrTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalAndTerm nl nr pevalOrTerm l r = orTerm l r {-# INLINEABLE pevalOrTerm #-} @@ -2497,6 +2502,10 @@ | andEqFirst r l2 = r | andEqFalse l1 r = pevalAndTerm l2 r | andEqFalse l2 r = pevalAndTerm l1 r +pevalAndTerm + (OrTerm _ l1 nl2@(NotTerm _ l2)) + (NotTerm _ (EqTerm _ (Dyn (e1 :: Term Bool)) (Dyn (e2 :: Term Bool)))) + | l1 == e1 && l2 == e2 = pevalAndTerm l1 nl2 pevalAndTerm (NotTerm _ nl) (NotTerm _ nr) = pevalNotTerm $ pevalOrTerm nl nr pevalAndTerm l r = andTerm l r {-# INLINEABLE pevalAndTerm #-} diff --git a/src/Grisette/Internal/SymPrim/Prim/Model.hs b/src/Grisette/Internal/SymPrim/Prim/Model.hs --- a/src/Grisette/Internal/SymPrim/Prim/Model.hs +++ b/src/Grisette/Internal/SymPrim/Prim/Model.hs @@ -185,10 +185,19 @@ -- >>> import Grisette.SymPrim -- >>> :set -XFlexibleContexts --- | Symbolic constant set. +-- | Set of symbols. +-- +-- Check 'Grisette.Core.SymbolSetOps' for operations, and +-- 'Grisette.Core.SymbolSetRep' for manual constructions. newtype SymbolSet = SymbolSet {unSymbolSet :: S.HashSet SomeTypedSymbol} - deriving (Eq, Generic, Hashable, Semigroup, Monoid) + deriving (Eq, Generic, Hashable) +instance Semigroup SymbolSet where + SymbolSet s1 <> SymbolSet s2 = SymbolSet $ S.union s1 s2 + +instance Monoid SymbolSet where + mempty = emptySet + instance Show SymbolSet where showsPrec prec (SymbolSet s) = showParen (prec >= 10) $ \x -> "SymbolSet {" @@ -201,8 +210,18 @@ go0 (x : xs) = x ++ ", " ++ go0 xs -- | Model returned by the solver. -newtype Model = Model {unModel :: M.HashMap SomeTypedSymbol ModelValue} deriving (Eq, Generic, Hashable, Semigroup, Monoid) +-- +-- Check 'Grisette.Core.ModelOps' for operations, and 'Grisette.Core.ModelRep' +-- for manual constructions. +newtype Model = Model {unModel :: M.HashMap SomeTypedSymbol ModelValue} + deriving (Eq, Generic, Hashable) +instance Semigroup Model where + Model m1 <> Model m2 = Model $ M.union m1 m2 + +instance Monoid Model where + mempty = emptyModel + instance Show Model where showsPrec prec (Model m) = showParen (prec >= 10) $ \x -> "Model {" @@ -214,6 +233,8 @@ go0 [(SomeTypedSymbol _ s, v)] = showUntyped s ++ " -> " ++ show v go0 ((SomeTypedSymbol _ s, v) : xs) = showUntyped s ++ " -> " ++ show v ++ ", " ++ go0 xs +-- | Given a typed symbol and a model, return the equation (symbol = value) +-- encoded in the model. equation :: TypedSymbol a -> Model -> Maybe (Term Bool) equation tsym@(TypedSymbol {}) m = withSymbolSupported tsym $ case valueOf tsym m of @@ -513,6 +534,7 @@ SomeTerm goTernary f a b c = SomeTerm $ f (gotyped a) (gotyped b) (gotyped c) +-- | Evaluate a term in the given model. evaluateTerm :: forall a. (SupportedPrim a) => Bool -> Model -> Term a -> Term a evaluateTerm fillDefault m t = case evaluateSomeTerm fillDefault m $ SomeTerm t of SomeTerm (t1 :: Term b) -> unsafeCoerce @(Term b) @(Term a) t1 diff --git a/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs b/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs --- a/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs +++ b/src/Grisette/Internal/SymPrim/Prim/ModelValue.hs @@ -28,6 +28,7 @@ type (:~~:) (HRefl), ) +-- | A value with its type information. data ModelValue where ModelValue :: forall v. (Show v, Eq v, Hashable v) => TypeRep v -> v -> ModelValue @@ -43,10 +44,12 @@ instance Hashable ModelValue where s `hashWithSalt` (ModelValue t v) = s `hashWithSalt` t `hashWithSalt` v +-- | Convert from a model value. Crashes if the types does not match. unsafeFromModelValue :: forall a. (Typeable a) => ModelValue -> a unsafeFromModelValue (ModelValue t v) = case eqTypeRep t (typeRep @a) of Just HRefl -> v _ -> error $ "Bad model value type, expected type: " ++ show (typeRep @a) ++ ", but got: " ++ show t +-- | Convert to a model value. toModelValue :: forall a. (Show a, Eq a, Hashable a, Typeable a) => a -> ModelValue toModelValue = ModelValue (typeRep @a) diff --git a/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs b/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs --- a/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs +++ b/src/Grisette/Internal/SymPrim/Prim/SomeTerm.hs @@ -21,6 +21,7 @@ identityWithTypeRep, ) +-- | Existential wrapper for symbolic Grisette terms. data SomeTerm where SomeTerm :: forall a. (SupportedPrim a) => Term a -> SomeTerm diff --git a/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs b/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs --- a/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs +++ b/src/Grisette/Internal/SymPrim/Prim/TermUtils.hs @@ -13,7 +13,7 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Internal.SymPrim.Prim.TermUtils - ( extractSymbolicsTerm, + ( extractTerm, castTerm, someTermsSize, someTermSize, @@ -93,8 +93,8 @@ ) import qualified Type.Reflection as R -extractSymbolicsSomeTerm :: SomeTerm -> S.HashSet SomeTypedSymbol -extractSymbolicsSomeTerm t1 = evalState (gocached t1) M.empty +extractSymSomeTerm :: SomeTerm -> S.HashSet SomeTypedSymbol +extractSymSomeTerm t1 = evalState (gocached t1) M.empty where gocached :: SomeTerm -> State (M.HashMap SomeTerm (S.HashSet SomeTypedSymbol)) (S.HashSet SomeTypedSymbol) gocached t = do @@ -166,12 +166,14 @@ r2 <- gocached (SomeTerm arg2) r3 <- gocached (SomeTerm arg3) return $ r1 <> r2 <> r3 -{-# INLINEABLE extractSymbolicsSomeTerm #-} +{-# INLINEABLE extractSymSomeTerm #-} -extractSymbolicsTerm :: (SupportedPrim a) => Term a -> S.HashSet SomeTypedSymbol -extractSymbolicsTerm t = extractSymbolicsSomeTerm (SomeTerm t) -{-# INLINE extractSymbolicsTerm #-} +-- | Extract all the symbols in a term. +extractTerm :: (SupportedPrim a) => Term a -> S.HashSet SomeTypedSymbol +extractTerm t = extractSymSomeTerm (SomeTerm t) +{-# INLINE extractTerm #-} +-- | Cast a term to another type. castTerm :: forall a b. (Typeable b) => Term a -> Maybe (Term b) castTerm t@ConTerm {} = cast t castTerm t@SymTerm {} = cast t @@ -219,6 +221,7 @@ castTerm t@FPFMATerm {} = cast t {-# INLINE castTerm #-} +-- | Compute the size of a list of terms. Do not count the same term twice. someTermsSize :: [SomeTerm] -> Int someTermsSize terms = S.size $ execState (traverse goSome terms) S.empty where @@ -313,14 +316,17 @@ go arg3 {-# INLINEABLE someTermsSize #-} +-- | Compute the size of a list of terms. Do not count the same term twice. someTermSize :: SomeTerm -> Int someTermSize term = someTermsSize [term] {-# INLINE someTermSize #-} +-- | Compute the size of a list of terms. Do not count the same term twice. termsSize :: [Term a] -> Int termsSize terms = someTermsSize $ (\x -> introSupportedPrimConstraint x $ SomeTerm x) <$> terms {-# INLINEABLE termsSize #-} +-- | Compute the size of a term. termSize :: Term a -> Int termSize term = termsSize [term] {-# INLINE termSize #-} diff --git a/src/Grisette/Internal/SymPrim/SomeBV.hs b/src/Grisette/Internal/SymPrim/SomeBV.hs --- a/src/Grisette/Internal/SymPrim/SomeBV.hs +++ b/src/Grisette/Internal/SymPrim/SomeBV.hs @@ -59,7 +59,7 @@ import Control.DeepSeq (NFData (rnf)) import Control.Exception (throw) -import Control.Monad.Except (ExceptT, MonadError) +import Control.Monad.Except (ExceptT, MonadError (throwError), runExceptT) import Data.Bifunctor (Bifunctor (bimap)) import Data.Bits ( Bits @@ -100,7 +100,7 @@ type (+), type (<=), ) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM) +import Grisette.Internal.Core.Control.Monad.Union (Union) import Grisette.Internal.Core.Data.Class.BitVector ( BV (bv, bvConcat, bvExt, bvSelect, bvSext, bvZext), SizedBV @@ -112,14 +112,11 @@ sizedBVZext ), ) -import Grisette.Internal.Core.Data.Class.EvaluateSym - ( EvaluateSym (evaluateSym), - ) -import Grisette.Internal.Core.Data.Class.ExtractSymbolics - ( ExtractSymbolics (extractSymbolics), +import Grisette.Internal.Core.Data.Class.EvalSym + ( EvalSym (evalSym), ) -import Grisette.Internal.Core.Data.Class.GPretty - ( GPretty (gpretty), +import Grisette.Internal.Core.Data.Class.ExtractSym + ( ExtractSym (extractSym), ) import Grisette.Internal.Core.Data.Class.GenSym ( GenSym (fresh), @@ -131,9 +128,8 @@ MergingStrategy (SortedStrategy), wrapStrategy, ) -import Grisette.Internal.Core.Data.Class.SEq (SEq ((./=), (.==))) -import Grisette.Internal.Core.Data.Class.SOrd - ( SOrd (symCompare, (.<), (.<=), (.>), (.>=)), +import Grisette.Internal.Core.Data.Class.PPrint + ( PPrint (pformat), ) import Grisette.Internal.Core.Data.Class.SafeDivision ( SafeDivision (safeDiv, safeDivMod, safeMod, safeQuot, safeQuotRem, safeRem), @@ -158,14 +154,22 @@ import Grisette.Internal.Core.Data.Class.Solvable ( Solvable (con, conView, isym, ssym, sym), ) -import Grisette.Internal.Core.Data.Class.SubstituteSym - ( SubstituteSym (substituteSym), +import Grisette.Internal.Core.Data.Class.SubstSym + ( SubstSym (substSym), ) -import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate (symRotate, symRotateNegated)) -import Grisette.Internal.Core.Data.Class.SymShift (SymShift (symShift, symShiftNegated)) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((./=), (.==))) +import Grisette.Internal.Core.Data.Class.SymOrd + ( SymOrd (symCompare, (.<), (.<=), (.>), (.>=)), + ) +import Grisette.Internal.Core.Data.Class.SymRotate + ( SymRotate (symRotate, symRotateNegated), + ) +import Grisette.Internal.Core.Data.Class.SymShift + ( SymShift (symShift, symShiftNegated), + ) import Grisette.Internal.Core.Data.Class.ToCon (ToCon (toCon)) import Grisette.Internal.Core.Data.Class.ToSym (ToSym (toSym)) -import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) import Grisette.Internal.Core.Data.Symbol (Identifier, Symbol) import Grisette.Internal.SymPrim.AllSyms (AllSyms (allSyms, allSymsS)) import Grisette.Internal.SymPrim.BV @@ -188,7 +192,6 @@ unsafeKnownProof, unsafeLeqProof, ) -import Grisette.Lib.Control.Monad.Except (mrgModifyError, mrgThrowError) import Grisette.Lib.Data.Functor (mrgFmap) import Language.Haskell.TH.Syntax (Lift (liftTyped)) import Test.QuickCheck (Arbitrary (arbitrary), Gen) @@ -221,7 +224,7 @@ -- *** Exception: BitwidthMismatch -- -- One exception is that the equality testing (both concrete and symbolic via --- 'SEq') does not require the bitwidths to be the same. Different bitwidths +-- 'SymEq') does not require the bitwidths to be the same. Different bitwidths -- means the values are not equal: -- -- >>> (bv 4 0x3 :: SomeBV IntN) == (bv 8 0x3) @@ -455,25 +458,25 @@ {-# INLINE bv #-} instance - (forall n. (KnownNat n, 1 <= n) => EvaluateSym (bv n)) => - EvaluateSym (SomeBV bv) + (forall n. (KnownNat n, 1 <= n) => EvalSym (bv n)) => + EvalSym (SomeBV bv) where - evaluateSym fillDefault model = unarySomeBVR1 (evaluateSym fillDefault model) - {-# INLINE evaluateSym #-} + evalSym fillDefault model = unarySomeBVR1 (evalSym fillDefault model) + {-# INLINE evalSym #-} instance - (forall n. (KnownNat n, 1 <= n) => ExtractSymbolics (bv n)) => - ExtractSymbolics (SomeBV bv) + (forall n. (KnownNat n, 1 <= n) => ExtractSym (bv n)) => + ExtractSym (SomeBV bv) where - extractSymbolics = unarySomeBV extractSymbolics - {-# INLINE extractSymbolics #-} + extractSym = unarySomeBV extractSym + {-# INLINE extractSym #-} instance - (forall n. (KnownNat n, 1 <= n) => GPretty (bv n)) => - GPretty (SomeBV bv) + (forall n. (KnownNat n, 1 <= n) => PPrint (bv n)) => + PPrint (SomeBV bv) where - gpretty (SomeBV bv) = gpretty bv - {-# INLINE gpretty #-} + pformat (SomeBV bv) = pformat bv + {-# INLINE pformat #-} data CompileTimeNat where CompileTimeNat :: (KnownNat n, 1 <= n) => Proxy n -> CompileTimeNat @@ -510,7 +513,7 @@ (\(SomeBV x) -> unsafeCoerce x) ) -instance (forall n. (KnownNat n, 1 <= n) => SEq (bv n)) => SEq (SomeBV bv) where +instance (forall n. (KnownNat n, 1 <= n) => SymEq (bv n)) => SymEq (SomeBV bv) where SomeBV (l :: bv l) .== SomeBV (r :: bv r) = case sameNat (Proxy @l) (Proxy @r) of Just Refl -> l .== r @@ -523,8 +526,8 @@ {-# INLINE (./=) #-} instance - (forall n. (KnownNat n, 1 <= n) => SOrd (bv n)) => - SOrd (SomeBV bv) + (forall n. (KnownNat n, 1 <= n) => SymOrd (bv n)) => + SymOrd (SomeBV bv) where (.<) = binSomeBV (.<) {-# INLINE (.<) #-} @@ -538,11 +541,11 @@ {-# INLINE symCompare #-} instance - (forall n. (KnownNat n, 1 <= n) => SubstituteSym (bv n)) => - SubstituteSym (SomeBV bv) + (forall n. (KnownNat n, 1 <= n) => SubstSym (bv n)) => + SubstSym (SomeBV bv) where - substituteSym c s = unarySomeBVR1 (substituteSym c s) - {-# INLINE substituteSym #-} + substSym c s = unarySomeBVR1 (substSym c s) + {-# INLINE substSym #-} instance ( KnownNat n, @@ -553,7 +556,7 @@ GenSym (Proxy n) (SomeBV bv) where fresh _ = - (\(i :: UnionM (bv n)) -> mrgFmap SomeBV i) <$> fresh () + (\(i :: Union (bv n)) -> mrgFmap SomeBV i) <$> fresh () {-# INLINE fresh #-} instance @@ -672,7 +675,12 @@ {-# INLINE safeAdd #-} safeSub = binSomeBVSafeR1 (safeSub @e) {-# INLINE safeSub #-} - safeNeg = unarySomeBV (mrgFmap SomeBV . mrgModifyError Right . safeNeg @e) + safeNeg = + unarySomeBV + ( \v -> + mrgFmap SomeBV $ + runExceptT (safeNeg @e v) >>= either (throwError . Right) pure + ) {-# INLINE safeNeg #-} instance @@ -744,31 +752,31 @@ -- Synonyms --- | Type synonym for 'SomeBV' with concrete signed bitvectors. +-- | Type synonym for 'SomeBV' for concrete signed bitvectors. type SomeIntN = SomeBV IntN --- | Pattern synonym for 'SomeBV' with concrete signed bitvectors. +-- | Pattern synonym for 'SomeBV' for concrete signed bitvectors. pattern SomeIntN :: () => (KnownNat n, 1 <= n) => IntN n -> SomeIntN pattern SomeIntN a = SomeBV a --- | Type synonym for 'SomeBV' with concrete unsigned bitvectors. +-- | Type synonym for 'SomeBV' for concrete unsigned bitvectors. type SomeWordN = SomeBV WordN --- | Pattern synonym for 'SomeBV' with concrete unsigned bitvectors. +-- | Pattern synonym for 'SomeBV' for concrete unsigned bitvectors. pattern SomeWordN :: () => (KnownNat n, 1 <= n) => WordN n -> SomeWordN pattern SomeWordN a = SomeBV a --- | Type synonym for 'SomeBV' with symbolic signed bitvectors. +-- | Type synonym for 'SomeBV' for symbolic signed bitvectors. type SomeSymIntN = SomeBV SymIntN --- | Pattern synonym for 'SomeBV' with symbolic signed bitvectors. +-- | Pattern synonym for 'SomeBV' for symbolic signed bitvectors. pattern SomeSymIntN :: () => (KnownNat n, 1 <= n) => SymIntN n -> SomeSymIntN pattern SomeSymIntN a = SomeBV a --- | Type synonym for 'SomeBV' with symbolic unsigned bitvectors. +-- | Type synonym for 'SomeBV' for symbolic unsigned bitvectors. type SomeSymWordN = SomeBV SymWordN --- | Pattern synonym for 'SomeBV' with symbolic unsigned bitvectors. +-- | Pattern synonym for 'SomeBV' for symbolic unsigned bitvectors. pattern SomeSymWordN :: () => (KnownNat n, 1 <= n) => SymWordN n -> SomeSymWordN pattern SomeSymWordN a = SomeBV a @@ -820,7 +828,7 @@ Nothing -> Nothing -- | Pattern synonym for symbolic 'SomeBV' to see if it contains a concrete --- value and extract it. Similar to 'Con' but for 'SomeBV'. +-- value and extract it. Similar to 'Grisette.Core.Con' but for 'SomeBV'. -- -- >>> case (bv 8 0x12 :: SomeSymIntN) of { ConBV c -> c; _ -> error "impossible" } -- 0x12 @@ -960,8 +968,9 @@ m r binSomeBVSafe f (SomeBV (l :: bv l)) (SomeBV (r :: bv r)) = case sameNat (Proxy @l) (Proxy @r) of - Just Refl -> mrgModifyError Right $ f l r - Nothing -> mrgThrowError $ Left BitwidthMismatch + Just Refl -> + tryMerge $ runExceptT (f l r) >>= either (throwError . Right) pure + Nothing -> tryMerge $ throwError $ Left BitwidthMismatch {-# INLINE binSomeBVSafe #-} -- | Lift a binary operation on sized bitvectors that returns a bitvector diff --git a/src/Grisette/Internal/SymPrim/SymBV.hs b/src/Grisette/Internal/SymPrim/SymBV.hs --- a/src/Grisette/Internal/SymPrim/SymBV.hs +++ b/src/Grisette/Internal/SymPrim/SymBV.hs @@ -27,8 +27,16 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Internal.SymPrim.SymBV - ( SymWordN (..), - SymIntN (..), + ( SymWordN (SymWordN), + SymWordN8, + SymWordN16, + SymWordN32, + SymWordN64, + SymIntN (SymIntN), + SymIntN8, + SymIntN16, + SymIntN32, + SymIntN64, ) where @@ -154,11 +162,23 @@ -- >>> (8 :: SymIntN 4) .< (7 :: SymIntN 4) -- true -- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. +-- More operations are available. Please refer to "Grisette.Core#g:symops" for +-- more information. newtype SymIntN (n :: Nat) = SymIntN {underlyingIntNTerm :: Term (IntN n)} deriving (Lift, NFData, Generic) +-- | Symbolic 8-bit signed bit-vector. +type SymIntN8 = SymIntN 8 + +-- | Symbolic 16-bit signed bit-vector. +type SymIntN16 = SymIntN 16 + +-- | Symbolic 32-bit signed bit-vector. +type SymIntN32 = SymIntN 32 + +-- | Symbolic 64-bit signed bit-vector. +type SymIntN64 = SymIntN 64 + -- | Symbolic unsigned bit vector type. Indexed with the bit width. -- Signedness affects the semantics of the operations, including -- comparison/extension, etc. @@ -173,10 +193,22 @@ -- >>> (8 :: SymWordN 4) .< (7 :: SymWordN 4) -- false -- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. +-- More operations are available. Please refer to "Grisette.Core#g:symops" for +-- more information. newtype SymWordN (n :: Nat) = SymWordN {underlyingWordNTerm :: Term (WordN n)} deriving (Lift, NFData, Generic) + +-- | Symbolic 8-bit unsigned bit-vector. +type SymWordN8 = SymWordN 8 + +-- | Symbolic 16-bit unsigned bit-vector. +type SymWordN16 = SymWordN 16 + +-- | Symbolic 32-bit unsigned bit-vector. +type SymWordN32 = SymWordN 32 + +-- | Symbolic 64-bit unsigned bit-vector. +type SymWordN64 = SymWordN 64 instance (KnownNat n, 1 <= n) => ConRep (SymIntN n) where type ConType (SymIntN n) = IntN n diff --git a/src/Grisette/Internal/SymPrim/SymBool.hs b/src/Grisette/Internal/SymPrim/SymBool.hs --- a/src/Grisette/Internal/SymPrim/SymBool.hs +++ b/src/Grisette/Internal/SymPrim/SymBool.hs @@ -46,8 +46,8 @@ -- >>> "a" .&& "b" :: SymBool -- (&& a b) -- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. +-- More operations are available. Please refer to "Grisette.Core#g:symops" for +-- more information. newtype SymBool = SymBool {underlyingBoolTerm :: Term Bool} deriving (Lift, NFData, Generic) diff --git a/src/Grisette/Internal/SymPrim/SymFP.hs b/src/Grisette/Internal/SymPrim/SymFP.hs --- a/src/Grisette/Internal/SymPrim/SymFP.hs +++ b/src/Grisette/Internal/SymPrim/SymFP.hs @@ -7,12 +7,20 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +-- | +-- Module : Grisette.Internal.SymPrim.SymFP +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Internal.SymPrim.SymFP ( SymFP (SymFP), SymFP16, SymFP32, SymFP64, - SymFPRoundingMode (..), + SymFPRoundingMode (SymFPRoundingMode), ) where @@ -47,8 +55,23 @@ ) import Language.Haskell.TH.Syntax (Lift) +-- $setup +-- >>> import Grisette.Core +-- >>> import Grisette.SymPrim +-- >>> import Grisette.Backend +-- >>> import Data.Proxy + -- | Symbolic IEEE 754 floating-point number with @eb@ exponent bits and @sb@ -- significand bits. +-- +-- >>> :set -XOverloadedStrings -XDataKinds +-- >>> "a" + 2.0 :: SymFP 11 53 +-- (+ a 2.0) +-- >>> symFpAdd rne "a" 2.0 :: SymFP 11 53 +-- (fp.add rne a 2.0) +-- +-- More operations are available. Please refer to "Grisette.Core#g:symops" for +-- more information. newtype SymFP eb sb = SymFP {underlyingFPTerm :: Term (FP eb sb)} deriving (Lift, Generic) deriving anyclass (NFData) @@ -129,6 +152,7 @@ acosh = error "acosh isn't supported by the underlying sbv library" atanh = error "atanh isn't supported by the underlying sbv library" +-- | Symbolic floating-point rounding mode. newtype SymFPRoundingMode = SymFPRoundingMode (Term FPRoundingMode) deriving (Lift, Generic) deriving anyclass (NFData) diff --git a/src/Grisette/Internal/SymPrim/SymGeneralFun.hs b/src/Grisette/Internal/SymPrim/SymGeneralFun.hs --- a/src/Grisette/Internal/SymPrim/SymGeneralFun.hs +++ b/src/Grisette/Internal/SymPrim/SymGeneralFun.hs @@ -22,7 +22,7 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.Internal.SymPrim.SymGeneralFun - ( type (-~>) (..), + ( type (-~>) (SymGeneralFun), (-->), ) where @@ -94,8 +94,11 @@ -- \(a:ARG :: Integer) -> (+ 1 a:ARG) -- -- This general symbolic function needs to be applied to symbolic values: +-- -- >>> f # ("a" :: SymInteger) -- (+ 1 a) +-- >>> f # (2 :: SymInteger) +-- 3 (-->) :: (SupportedPrim ca, SupportedPrim cb, LinkedRep cb sb) => TypedSymbol ca -> diff --git a/src/Grisette/Internal/SymPrim/SymInteger.hs b/src/Grisette/Internal/SymPrim/SymInteger.hs --- a/src/Grisette/Internal/SymPrim/SymInteger.hs +++ b/src/Grisette/Internal/SymPrim/SymInteger.hs @@ -51,8 +51,8 @@ -- >>> "a" + 1 :: SymInteger -- (+ 1 a) -- --- More symbolic operations are available. Please refer to the documentation --- for the type class instances. +-- More operations are available. Please refer to "Grisette.Core#g:symops" for +-- more information. newtype SymInteger = SymInteger {underlyingIntegerTerm :: Term Integer} deriving (Lift, NFData, Generic) diff --git a/src/Grisette/Internal/SymPrim/SymTabularFun.hs b/src/Grisette/Internal/SymPrim/SymTabularFun.hs --- a/src/Grisette/Internal/SymPrim/SymTabularFun.hs +++ b/src/Grisette/Internal/SymPrim/SymTabularFun.hs @@ -18,7 +18,10 @@ -- Maintainer : siruilu@cs.washington.edu -- Stability : Experimental -- Portability : GHC only -module Grisette.Internal.SymPrim.SymTabularFun (type (=~>) (..)) where +module Grisette.Internal.SymPrim.SymTabularFun + ( type (=~>) (SymTabularFun), + ) +where import Control.DeepSeq (NFData (rnf)) import Data.Hashable (Hashable (hashWithSalt)) diff --git a/src/Grisette/Internal/TH/DeriveBuiltin.hs b/src/Grisette/Internal/TH/DeriveBuiltin.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/DeriveBuiltin.hs @@ -0,0 +1,82 @@ +-- | +-- Module : Grisette.Internal.TH.DeriveBuiltin +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.DeriveBuiltin + ( deriveBuiltinExtra, + deriveBuiltin, + deriveBuiltins, + ) +where + +import Control.Monad (when) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (strategyClassName), + ) +import Grisette.Internal.TH.DeriveTypeParamHandler + ( NatShouldBePositive (NatShouldBePositive), + PrimaryConstraint (PrimaryConstraint), + SomeDeriveTypeParamHandler (SomeDeriveTypeParamHandler), + ) +import Grisette.Internal.TH.DeriveWithHandlers + ( deriveWithHandlers, + ) +import Grisette.Internal.TH.Util + ( classNumParam, + classParamKinds, + kindNumParam, + ) +import Language.Haskell.TH (Dec, Name, Q) + +-- | Derive a builtin class for a type, with extra handlers. +deriveBuiltinExtra :: + [SomeDeriveTypeParamHandler] -> Bool -> Strategy -> [Name] -> Name -> Q [Dec] +deriveBuiltinExtra + extraHandlers + ignoreBodyConstraints + strategy + constraints + name = do + let finalCtxName = strategyClassName strategy + numParam <- classNumParam finalCtxName + when (numParam == 0) $ + fail "deriveBuiltin: the class must have at least one parameter" + kinds <- classParamKinds finalCtxName + case kinds of + [] -> + fail $ + "deriveBuiltin: the class must have at least one parameter, bug, " + <> "should not happen" + (k : ks) -> do + when (any (/= k) ks) $ + fail "deriveBuiltin: all parameters must have the same kind" + constraintNumParams <- mapM classNumParam constraints + when (any (/= numParam) constraintNumParams) $ + fail $ + "deriveBuiltin: all constraints must have the same number of " + <> "parameters as the results" + numDrop <- kindNumParam k + deriveWithHandlers + ( SomeDeriveTypeParamHandler NatShouldBePositive + : extraHandlers + <> ( (SomeDeriveTypeParamHandler . flip PrimaryConstraint False) + <$> constraints + ) + ) + strategy + ignoreBodyConstraints + numDrop + (replicate numParam name) + +-- | Derive a builtin class for a type. +deriveBuiltin :: Strategy -> [Name] -> Name -> Q [Dec] +deriveBuiltin = deriveBuiltinExtra [] True + +-- | Derive builtin classes for a list of types. +deriveBuiltins :: Strategy -> [Name] -> [Name] -> Q [Dec] +deriveBuiltins strategy constraints = + fmap concat . traverse (deriveBuiltin strategy constraints) diff --git a/src/Grisette/Internal/TH/DeriveInstanceProvider.hs b/src/Grisette/Internal/TH/DeriveInstanceProvider.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/DeriveInstanceProvider.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Grisette.Internal.TH.DeriveInstanceProvider +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.DeriveInstanceProvider + ( DeriveInstanceProvider (..), + Strategy (..), + ) +where + +import Generics.Deriving (Default, Default1) +import Language.Haskell.TH + ( Dec, + DerivStrategy + ( AnyclassStrategy, + NewtypeStrategy, + StockStrategy, + ViaStrategy + ), + Name, + Pred, + Q, + Type, + appT, + conT, + standaloneDerivWithStrategyD, + ) +import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit) + +-- | A derive instance provider provides the instance declaration. +class DeriveInstanceProvider provider where + instanceDeclaration :: + provider -> [[(TyVarBndrUnit, Maybe Type)]] -> [Pred] -> [Type] -> Q [Dec] + +-- | A strategy for deriving instances. +data Strategy + = Stock {strategyClassName :: Name} + | WithNewtype {strategyClassName :: Name} + | ViaDefault {strategyClassName :: Name} + | ViaDefault1 {strategyClassName :: Name} + | Anyclass {strategyClassName :: Name} + deriving (Eq) + +getStrategy :: Strategy -> Type -> Q DerivStrategy +getStrategy strategy ty = + case strategy of + Stock _ -> return StockStrategy + WithNewtype _ -> return NewtypeStrategy + ViaDefault _ -> + ViaStrategy + <$> [t|Default $(return ty)|] + ViaDefault1 _ -> + ViaStrategy + <$> [t|Default1 $(return ty)|] + Anyclass _ -> return AnyclassStrategy + +instance DeriveInstanceProvider Strategy where + instanceDeclaration strategy _ preds tys = do + s <- getStrategy strategy (last tys) + (: []) + <$> standaloneDerivWithStrategyD + (Just s) + (return preds) + (foldl appT (conT $ strategyClassName strategy) $ return <$> tys) diff --git a/src/Grisette/Internal/TH/DerivePredefined.hs b/src/Grisette/Internal/TH/DerivePredefined.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/DerivePredefined.hs @@ -0,0 +1,335 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Grisette.Internal.TH.DerivePredefined +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.DerivePredefined + ( derivePredefined, + derivePredefinedMultipleClasses, + derive, + deriveAll, + deriveAllExcept, + ) +where + +import Control.DeepSeq (NFData, NFData1) +import Data.Functor.Classes (Eq1, Ord1, Show1) +import Data.Hashable (Hashable) +import Data.Hashable.Lifted (Hashable1) +import GHC.Generics (Generic) +import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym, EvalSym1) +import Grisette.Internal.Core.Data.Class.ExtractSym + ( ExtractSym, + ExtractSym1, + ) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, Mergeable1) +import Grisette.Internal.Core.Data.Class.PPrint (PPrint, PPrint1) +import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq, SymEq1) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd, SymOrd1) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon, ToCon1) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym, ToSym1) +import Grisette.Internal.SymPrim.AllSyms (AllSyms, AllSyms1) +import Grisette.Internal.TH.DeriveBuiltin + ( deriveBuiltinExtra, + ) +import Grisette.Internal.TH.DeriveInstanceProvider + ( Strategy (Anyclass, Stock, ViaDefault, WithNewtype), + ) +import Grisette.Internal.TH.DeriveTypeParamHandler + ( DeriveTypeParamHandler (handleBody, handleTypeParams), + PrimaryConstraint (PrimaryConstraint), + SomeDeriveTypeParamHandler (SomeDeriveTypeParamHandler), + ) +import Grisette.Internal.TH.DeriveUnifiedInterface + ( deriveFunctorArgUnifiedInterfaceExtra, + ) +import Grisette.Internal.TH.DeriveWithHandlers (deriveWithHandlers) +import Grisette.Internal.TH.Util (classParamKinds, concatPreds) +import Grisette.Unified.Internal.Class.UnifiedSymEq + ( UnifiedSymEq (withBaseSymEq), + UnifiedSymEq1 (withBaseSymEq1), + ) +import Grisette.Unified.Internal.Class.UnifiedSymOrd + ( UnifiedSymOrd (withBaseSymOrd), + UnifiedSymOrd1 (withBaseSymOrd1), + ) +import Grisette.Unified.Internal.EvalMode (EvalMode) +import Grisette.Unified.Internal.EvalModeTag + ( EvalModeTag (Con, Sym), + ) +import Language.Haskell.TH + ( Dec, + Kind, + Name, + Pred, + Q, + Type (ConT, PromotedT), + appT, + conT, + varT, + ) +import Language.Haskell.TH.Datatype + ( DatatypeInfo (datatypeVariant), + DatatypeVariant (Datatype, Newtype), + reifyDatatype, + tvKind, + tvName, + ) +import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit) +import Language.Haskell.TH.Syntax (Lift) + +newtypeDefaultStrategy :: Name -> Q Strategy +newtypeDefaultStrategy nm + | nm == ''Show = return $ Stock nm + | nm == ''PPrint = return $ ViaDefault nm + | nm == ''Lift = return $ Stock nm + | nm == ''ToCon = return $ ViaDefault nm + | nm == ''ToSym = return $ ViaDefault nm + | otherwise = return $ WithNewtype nm + +dataDefaultStrategy :: Name -> Q Strategy +dataDefaultStrategy nm + | nm == ''Show = return $ Stock nm + | nm == ''Eq = return $ Stock nm + | nm == ''Ord = return $ Stock nm + | nm == ''Lift = return $ Stock nm + | nm == ''NFData = return $ Anyclass nm + | nm == ''Hashable = return $ Anyclass nm + | nm == ''ToCon = return $ ViaDefault nm + | nm == ''ToSym = return $ ViaDefault nm + | nm == ''AllSyms = return $ ViaDefault nm + | nm == ''EvalSym = return $ ViaDefault nm + | nm == ''ExtractSym = return $ ViaDefault nm + | nm == ''PPrint = return $ ViaDefault nm + | nm == ''Mergeable = return $ ViaDefault nm + | nm == ''SymEq = return $ ViaDefault nm + | nm == ''SymOrd = return $ ViaDefault nm + | nm == ''SubstSym = return $ ViaDefault nm + | otherwise = fail $ "Unsupported class: " <> show nm + +allNeededConstraints :: Name -> [Name] +allNeededConstraints nm + | nm == ''Show = [''Show, ''Show1] + | nm == ''Eq = [''Eq, ''Eq1] + | nm == ''Ord = [''Ord, ''Ord1] + | nm == ''Lift = [''Lift] + | nm == ''NFData = [''NFData, ''NFData1] + | nm == ''Hashable = [''Hashable, ''Hashable1] + | nm == ''AllSyms = [''AllSyms, ''AllSyms1] + | nm == ''EvalSym = + [''EvalSym, ''EvalSym1, ''Mergeable, ''Mergeable1] + | nm == ''ExtractSym = [''ExtractSym, ''ExtractSym1] + | nm == ''PPrint = [''PPrint, ''PPrint1] + | nm == ''Mergeable = [''Mergeable1, ''Mergeable1] + | nm == ''ToCon = [''ToCon, ''ToCon1] + | nm == ''ToSym = [''ToSym, ''ToSym1] + | nm == ''SymEq = [''SymEq, ''SymEq1, ''Mergeable, ''Mergeable1] + | nm == ''SymOrd = [''SymOrd, ''SymOrd1, ''Mergeable, ''Mergeable1] + | nm == ''SubstSym = + [''SubstSym, ''SubstSym, ''Mergeable, ''Mergeable1] + | otherwise = [] + +newtype ModeTypeParamHandler = ModeTypeParamHandler + { mode :: Maybe EvalModeTag + } + +instance DeriveTypeParamHandler ModeTypeParamHandler where + handleTypeParams _ ModeTypeParamHandler {..} tys = do + mapM (uncurry handle) tys + where + handle :: + [(TyVarBndrUnit, Maybe Type)] -> + Maybe [Pred] -> + Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) + handle [(ty, substTy)] preds | tvKind ty == ConT ''EvalModeTag = + case (mode, substTy) of + (_, Just {}) -> return ([(ty, substTy)], preds) + (Just Con, _) -> return ([(ty, Just $ PromotedT 'Con)], preds) + (Just Sym, _) -> return ([(ty, Just $ PromotedT 'Sym)], preds) + (Nothing, _) -> do + evalMode <- [t|EvalMode $(varT $ tvName ty)|] + return ([(ty, substTy)], concatPreds (Just [evalMode]) preds) + handle tys preds = return (tys, preds) + handleBody _ _ = return [] + +newtype FixInnerConstraints = FixInnerConstraints {cls :: Name} + +instance DeriveTypeParamHandler FixInnerConstraints where + handleTypeParams _ _ = return + handleBody FixInnerConstraints {..} types = do + kinds <- classParamKinds cls + concat <$> mapM (handle kinds) types + where + handle :: [Kind] -> [Type] -> Q [Pred] + handle k tys + | length k /= length tys = + fail "FixInnerConstraints: kind and type length mismatch" + | otherwise = do + constr <- foldl appT (conT cls) $ return <$> tys + return [constr] + +-- | Derive instances for a type with the given name, with the predefined +-- strategy. +derivePredefined :: Maybe EvalModeTag -> Name -> Name -> Q [Dec] +derivePredefined _ cls name + | cls == ''Generic = + deriveWithHandlers [] (Stock ''Generic) True 0 [name] +derivePredefined _ cls name + | cls == ''UnifiedSymEq = + deriveFunctorArgUnifiedInterfaceExtra + [ SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable False, + SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable1 False + ] + ''UnifiedSymEq + 'withBaseSymEq + ''UnifiedSymEq1 + 'withBaseSymEq1 + name +derivePredefined _ cls name + | cls == ''UnifiedSymOrd = + deriveFunctorArgUnifiedInterfaceExtra + [ SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable False, + SomeDeriveTypeParamHandler $ PrimaryConstraint ''Mergeable1 False + ] + ''UnifiedSymOrd + 'withBaseSymOrd + ''UnifiedSymOrd1 + 'withBaseSymOrd1 + name +derivePredefined evmode cls name = do + d <- reifyDatatype name + strategy <- + if + | datatypeVariant d == Datatype -> dataDefaultStrategy cls + | datatypeVariant d == Newtype -> newtypeDefaultStrategy cls + | otherwise -> + fail "Currently only non-GADTs data or newtype are supported." + deriveBuiltinExtra + [ SomeDeriveTypeParamHandler $ ModeTypeParamHandler evmode, + SomeDeriveTypeParamHandler $ FixInnerConstraints cls + ] + False + strategy + (allNeededConstraints cls) + name + +-- | Derive instances for a type with the given name, with the predefined +-- strategy. +-- +-- Multiple classes can be derived at once. +derivePredefinedMultipleClasses :: + Maybe EvalModeTag -> [Name] -> Name -> Q [Dec] +derivePredefinedMultipleClasses evmode clss name = + concat <$> traverse (\cls -> derivePredefined evmode cls name) clss + +allGrisetteClasses :: [Name] +allGrisetteClasses = + [ ''Generic, + ''Show, + ''Eq, + ''Ord, + ''Lift, + ''NFData, + ''Hashable, + ''AllSyms, + ''EvalSym, + ''ExtractSym, + ''PPrint, + ''Mergeable, + ''SymEq, + ''SymOrd, + ''SubstSym, + ''ToCon, + ''ToSym, + ''UnifiedSymEq, + ''UnifiedSymOrd + ] + +-- | Derive specified classes for a type with the given name. +-- +-- Support the same set of classes as 'deriveAll'. +derive :: Name -> [Name] -> Q [Dec] +derive = flip (derivePredefinedMultipleClasses Nothing) + +-- | Derive all classes related to Grisette for a type with the given name. +-- +-- Classes that are be derived by this procedure are: +-- +-- * 'Generic' +-- * 'Show' +-- * 'Eq' +-- * 'Ord' +-- * 'Lift' +-- * 'NFData' +-- * 'Hashable' +-- * 'AllSyms' +-- * 'EvalSym' +-- * 'ExtractSym' +-- * 'PPrint' +-- * 'Mergeable' +-- * 'SymEq' +-- * 'SymOrd' +-- * 'SubstSym' +-- * 'ToCon' +-- * 'ToSym' +-- * 'UnifiedSymEq' +-- * 'UnifiedSymOrd' +-- +-- 'Ord' isn't valid for all types (symbolic-only types), so it may be necessary +-- to exclude it. +-- +-- 'deriveAll' needs the following language extensions: +-- +-- * DeriveAnyClass +-- * DeriveGeneric +-- * DeriveLift +-- * DerivingVia +-- * FlexibleContexts +-- * FlexibleInstances +-- * MonoLocalBinds +-- * MultiParamTypeClasses +-- * ScopedTypeVariables +-- * StandaloneDeriving +-- * TemplateHaskell +-- * TypeApplications +-- * UndecidableInstances +-- +-- Deriving for a newtype may also need +-- +-- * GeneralizedNewtypeDeriving +-- +-- You may get warnings if you don't have the following extensions: +-- +-- * TypeOperators +-- +-- It also requires that the v'Generics.Deriving.Default.Default' data +-- constructor is visible. +-- You may get strange errors if you only import +-- v'Generics.Deriving.Default.Default' type but not the data constructor. +deriveAll :: Name -> Q [Dec] +deriveAll = derivePredefinedMultipleClasses Nothing allGrisetteClasses + +-- | Derive all classes related to Grisette for a type with the given name, +-- except for the given classes. +-- +-- Excluding 'Ord' or 'SymOrd' will also exclude 'UnifiedSymOrd'. +-- Excluding 'Eq' or 'SymEq' will also exclude 'UnifiedSymEq'. +deriveAllExcept :: Name -> [Name] -> Q [Dec] +deriveAllExcept nm clss = + derivePredefinedMultipleClasses + Nothing + (filter (`notElem` allExcluded) allGrisetteClasses) + nm + where + allExcluded = + ([''UnifiedSymEq | ''Eq `elem` clss || ''SymEq `elem` clss]) + <> ([''UnifiedSymOrd | ''Ord `elem` clss || ''SymOrd `elem` clss]) + <> clss diff --git a/src/Grisette/Internal/TH/DeriveTypeParamHandler.hs b/src/Grisette/Internal/TH/DeriveTypeParamHandler.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/DeriveTypeParamHandler.hs @@ -0,0 +1,197 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.Internal.TH.DeriveTypeParamHandler +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.DeriveTypeParamHandler + ( DeriveTypeParamHandler (..), + NatShouldBePositive (..), + IsFPBits (..), + PrimaryConstraint (..), + SomeDeriveTypeParamHandler (..), + ) +where + +import GHC.TypeLits (KnownNat, Nat, type (<=)) +import Grisette.Internal.SymPrim.FP (ValidFP) +import Grisette.Internal.TH.Util + ( allSameKind, + classParamKinds, + concatPreds, + getTypeWithMaybeSubst, + ) +import Language.Haskell.TH (Kind, Name, Pred, Q, Type (ConT), appT, conT) +import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit, tvKind) + +-- | A derive type param handler handles type parameters and provides +-- constraints or instantiations for them. +-- +-- The first argument is the number of types that are zipped together. For +-- most classes, this is 1, but for some classes, like 'Grisette.ToCon', this is +-- 2. +-- +-- The second argument is the handler itself. +-- +-- The third argument is a list of type parameters and their constraints. Each +-- entry in the list corresponds to a type parameter of the datatype. The +-- first element in the pair is a list of zipped type parameters with possibly +-- concrete types. For example, if we are deriving 'Grisette.ToCon' for +-- `Either`, the argument will be: +-- +-- > [([(e0, Nothing), (e1, Nothing)], Nothing), +-- > ([(a0, Nothing), (a1, Nothing)], Nothing)] +-- +-- We can see that the type parameters for the concrete and symbolic `Either` +-- types are zipped together: the first element of the list are for the error +-- types, and the second element of the list are for the value types. +-- +-- The handler may concretize some types, or add constraints based on the type +-- parameters. +class DeriveTypeParamHandler handler where + handleTypeParams :: + Int -> + handler -> + [([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])] -> + Q [([(TyVarBndrUnit, Maybe Type)], Maybe [Pred])] + handleBody :: handler -> [[Type]] -> Q [Pred] + +-- | Ensures that type parameters with the kind 'Nat' are known and positive. +data NatShouldBePositive = NatShouldBePositive + +instance DeriveTypeParamHandler NatShouldBePositive where + handleTypeParams _ _ = mapM (uncurry handle) + where + handle :: + [(TyVarBndrUnit, Maybe Type)] -> + Maybe [Pred] -> + Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) + handle [] preds = return ([], preds) + handle tys _ + | not (allSameKind (map fst tys)) = + fail "NatShouldBePositive: All type parameters must be aligned " + handle (ty : tys) Nothing + | tvKind (fst ty) == ConT ''Nat = do + let (t : ts) = map (uncurry getTypeWithMaybeSubst) $ ty : tys + knownPred <- [t|KnownNat $t|] + geq1Pred <- [t|1 <= $t|] + eqPreds <- mapM (\t' -> [t|$t ~ $t'|]) ts + return (ty : tys, Just $ knownPred : geq1Pred : eqPreds) + handle tys preds = return (tys, preds) + handleBody _ _ = return [] + +-- | Ensures that the type parameters are valid for floating point operations. +data IsFPBits = IsFPBits {ebIdx :: Int, sbIdx :: Int} + +instance DeriveTypeParamHandler IsFPBits where + handleTypeParams _ (IsFPBits ebIdx sbIdx) tys + | ebIdx >= length tys = + fail "IsFPBits: ebIdx out of bounds" + | sbIdx >= length tys = + fail "IsFPBits: sbIdx out of bounds" + | otherwise = do + let eb = tys !! ebIdx + let ebts = map (uncurry getTypeWithMaybeSubst) (fst eb) + let sb = tys !! sbIdx + let sbts = map (uncurry getTypeWithMaybeSubst) (fst sb) + case (ebts, sbts) of + _ + | length ebts /= length sbts -> + fail $ + "IsFPBits: eb and sb must have the same number of type " + <> "parameters. This might happen because of a bug in " + <> "Grisette" + | not (allSameKind (fst <$> fst eb)) -> + fail "IsFPBits: All type parameters must be aligned" + | not (allSameKind (fst <$> fst sb)) -> + fail "IsFPBits: All type parameters must be aligned" + ([], []) -> return tys + ((et : ets), (st : sts)) -> do + validFloat <- [t|ValidFP $et $st|] + eqebPreds <- mapM (\et' -> [t|$et ~ $et'|]) ets + eqsbPreds <- mapM (\st' -> [t|$st ~ $st'|]) sts + return $ + zipWith + ( \i (ts, preds) -> + if i == ebIdx + then + ( ts, + concatPreds + (Just $ validFloat : eqebPreds ++ eqsbPreds) + preds + ) + else + if i == sbIdx + then (ts, concatPreds (Just []) preds) + else (ts, preds) + ) + [0 ..] + tys + _ -> fail "IsFPBits: This should never happen" + handleBody _ _ = return [] + +-- | Adds a primary constraint to the type parameters. It applies the class +-- to each type parameter that are zipped into a list, with the desired kinds. +-- +-- For example, if we are deriving 'Grisette.ToCon' for `Either`, and the input +-- to this handler is as follows: +-- +-- > [([(e0, Nothing), (e1, Nothing)], Nothing), +-- > ([(a0, Nothing), (a1, Nothing)], Nothing)] +-- +-- Then this will generate constraints for the type parameters of `Either`: +-- +-- > [([(e0, Nothing), (e1, Nothing)], Just [ToCon e0 e1]), +-- > ([(a0, Nothing), (a1, Nothing)], Just [ToCon a0 a1])] +-- +-- Type parameters that are already handled by other handlers can be ignored. +data PrimaryConstraint = PrimaryConstraint + { className :: Name, + ignoreIfAlreadyHandled :: Bool + } + +instance DeriveTypeParamHandler PrimaryConstraint where + handleTypeParams + _ + (PrimaryConstraint className ignoreIfAlreadyHandled) + tys = do + kinds <- classParamKinds className + mapM (uncurry (handle kinds)) tys + where + handle :: + [Kind] -> + [(TyVarBndrUnit, Maybe Type)] -> + Maybe [Pred] -> + Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) + handle _ [] preds = return ([], preds) + handle _ tys _ + | not (allSameKind (map fst tys)) = + fail "PrimaryConstraint: All type parameters must be aligned" + handle _ tys (Just preds) + | ignoreIfAlreadyHandled = + return (tys, Just preds) + handle kinds tys preds + | (tvKind . fst <$> tys) == kinds = do + ts <- mapM (uncurry getTypeWithMaybeSubst) tys + cls <- foldl appT (conT className) $ return <$> ts + return (tys, concatPreds (Just [cls]) preds) + handle _ tys preds = return (tys, preds) + handleBody (PrimaryConstraint _ _) _ = return [] + +-- | A type that can handle type parameters. +data SomeDeriveTypeParamHandler where + SomeDeriveTypeParamHandler :: + (DeriveTypeParamHandler handler) => + handler -> + SomeDeriveTypeParamHandler + +instance DeriveTypeParamHandler SomeDeriveTypeParamHandler where + handleTypeParams n (SomeDeriveTypeParamHandler h) = handleTypeParams n h + handleBody (SomeDeriveTypeParamHandler h) = handleBody h diff --git a/src/Grisette/Internal/TH/DeriveUnifiedInterface.hs b/src/Grisette/Internal/TH/DeriveUnifiedInterface.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/DeriveUnifiedInterface.hs @@ -0,0 +1,336 @@ +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.Internal.TH.DeriveUnifiedInterface +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.DeriveUnifiedInterface + ( TypeableMode (..), + PrimaryUnifiedConstraint (..), + UnifiedInstance (..), + deriveUnifiedInterfaceExtra, + deriveUnifiedInterface, + deriveUnifiedInterfaces, + deriveUnifiedInterface1Extra, + deriveUnifiedInterface1, + deriveUnifiedInterface1s, + deriveFunctorArgUnifiedInterfaceExtra, + deriveFunctorArgUnifiedInterface, + deriveFunctorArgUnifiedInterfaces, + ) +where + +import Control.Monad (unless) +import Data.Typeable (Typeable) +import Grisette.Internal.TH.DeriveInstanceProvider + ( DeriveInstanceProvider (instanceDeclaration), + ) +import Grisette.Internal.TH.DeriveTypeParamHandler + ( DeriveTypeParamHandler (handleBody, handleTypeParams), + NatShouldBePositive (NatShouldBePositive), + SomeDeriveTypeParamHandler (SomeDeriveTypeParamHandler), + ) +import Grisette.Internal.TH.DeriveWithHandlers (deriveWithHandlers) +import Grisette.Internal.TH.Util + ( allSameKind, + classParamKinds, + concatPreds, + getTypeWithMaybeSubst, + tvIsMode, + tvIsStar, + tvIsStarToStar, + ) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag) +import Grisette.Unified.Internal.Util (withMode) +import Language.Haskell.TH + ( Dec, + Exp, + Inline (Inline), + Kind, + Name, + Phases (AllPhases), + Pred, + Q, + RuleMatch (FunLike), + Type (ConT), + appT, + conT, + instanceD, + lam1E, + newName, + normalB, + pragInlD, + valD, + varE, + varP, + ) +import Language.Haskell.TH.Datatype.TyVarBndr (TyVarBndrUnit, kindedTV, tvKind) + +-- | Add a 'Typeable' constraint to the modes. +data TypeableMode = TypeableMode + +instance DeriveTypeParamHandler TypeableMode where + handleTypeParams n _ tys = do + unless (n == 1) $ + fail $ + "TypeableMode: unified type class should have exactly one type " + <> "parameter" + let numModeParam = length $ (filter (tvIsMode . fst . head)) $ fst <$> tys + newTys <- + if numModeParam == 0 + then do + nm <- newName "mode" + return $ + ( [(kindedTV nm (ConT ''EvalModeTag), Nothing)], + Nothing + ) + : tys + else + if numModeParam == 1 + then return tys + else fail "TypeableMode: multiple mode type variables found" + mapM (uncurry handleMode) newTys + where + handleMode :: + [(TyVarBndrUnit, Maybe Type)] -> + Maybe [Pred] -> + Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) + handleMode [(tv, substTy)] preds | tvIsMode tv = do + typeable <- [t|Typeable $(getTypeWithMaybeSubst tv substTy)|] + return ([(tv, substTy)], concatPreds (Just [typeable]) preds) + handleMode tys preds = return (tys, preds) + handleBody _ _ = return [] + +-- | Add a primary unified constraint that applies to all the type parameters +-- with the desired kind. +data PrimaryUnifiedConstraint = PrimaryUnifiedConstraint Name Bool + +instance DeriveTypeParamHandler PrimaryUnifiedConstraint where + handleTypeParams + n + (PrimaryUnifiedConstraint className ignoreIfAlreadyHandled) + tys = do + unless (n == 1) $ + fail $ + "TypeableMode: unified type class should have exactly one type " + <> "parameter" + kinds <- classParamKinds className + let modes = filter (tvIsMode . fst . head) $ fst <$> tys + case modes of + [] -> fail "PrimaryUnifiedConstraint: No mode type variable found" + [[md]] -> do + mdTy <- uncurry getTypeWithMaybeSubst md + mapM (uncurry $ handle kinds mdTy) tys + [_] -> + fail "PrimaryUnifiedConstraint: multiple mode type variables found" + _ -> + fail "PrimaryUnifiedConstraint: multiple mode type variables found" + where + handle :: + [Kind] -> + Type -> + [(TyVarBndrUnit, Maybe Type)] -> + Maybe [Pred] -> + Q ([(TyVarBndrUnit, Maybe Type)], Maybe [Pred]) + handle _ _ [] preds = return ([], preds) + handle _ _ tys (Just preds) + | ignoreIfAlreadyHandled = + return (tys, Just preds) + handle _ _ tys _ + | not (allSameKind (map fst tys)) = + fail + "PrimaryUnifiedConstraint: All type parameters must be aligned" + handle kinds modety tys preds + | ConT ''EvalModeTag : (tvKind . fst <$> tys) == kinds = do + ts <- mapM (uncurry getTypeWithMaybeSubst) tys + cls <- + foldl appT (appT (conT className) (return modety)) $ + return <$> ts + return (tys, concatPreds (Just [cls]) preds) + handle _ _ tys preds = return (tys, preds) + handleBody (PrimaryUnifiedConstraint _ _) _ = return [] + +-- | Provide an instance for a unified interface. +data UnifiedInstance = UnifiedInstance + { _cls :: Name, + _clsWithFunc :: Name, + _withFunc :: Name, + _withFunc1 :: Maybe Name + } + +instance DeriveInstanceProvider UnifiedInstance where + instanceDeclaration + (UnifiedInstance cls clsWithFunc withFunc maybeWithFunc1) + tys' + ctx + ty' = do + unless (all ((== 1) . length) tys') $ + fail "UnifiedInstance: only support classes with one type parameter" + unless (length ty' == 1) $ + fail "UnifiedInstance: only support classes with one type parameter" + let tys = head <$> tys' + let modes = + map (uncurry getTypeWithMaybeSubst) $ filter (tvIsMode . fst) tys + let stars = + map (uncurry getTypeWithMaybeSubst) $ filter (tvIsStar . fst) tys + let starToStars = + map (uncurry getTypeWithMaybeSubst) $ + filter (tvIsStarToStar . fst) tys + case modes of + [] -> fail "UnifiedInstance: no mode type variables found" + [md] -> do + sequence + [ instanceD + (return ctx) + [t|$(conT cls) $md $(return $ head ty')|] + [ body md clsWithFunc withFunc stars maybeWithFunc1 starToStars, + pragInlD clsWithFunc Inline FunLike AllPhases + ] + ] + _ -> fail "UnifiedInstance: multiple mode type variables found" + where + applyWithFunc :: Name -> Q Type -> Q Type -> Q Exp -> Q Exp + applyWithFunc withFunc mode var exp = + [|$(varE withFunc) @($mode) @($var) $exp|] + body :: + Q Type -> Name -> Name -> [Q Type] -> Maybe Name -> [Q Type] -> Q Dec + body mode clsWithFunc withFunc starVars maybeWithFunc1 starToStarVars = + do + var <- newName "r" + let arg = varP var + let branch = foldr (applyWithFunc withFunc mode) (varE var) starVars + let withModeFunc = 'withMode + case (maybeWithFunc1, starToStarVars) of + (_, []) -> do + let exp = + lam1E + arg + [|$(varE withModeFunc) @($mode) $branch $branch|] + valD (varP clsWithFunc) (normalB exp) [] + (Just withFunc1, _) -> do + let branchWithFunc1 = + foldr (applyWithFunc withFunc1 mode) branch starToStarVars + let exp = + lam1E + arg + [| + $(varE withModeFunc) + @($mode) + $branchWithFunc1 + $branchWithFunc1 + |] + valD (varP clsWithFunc) (normalB exp) [] + (Nothing, _) -> + fail $ + "UnifiedInstance: withFunc1 is not provided, type have " + <> "functor type parameters" + +-- | Derive an instance for a unified interface, with extra handlers. +deriveUnifiedInterfaceExtra :: + [SomeDeriveTypeParamHandler] -> + Name -> + Name -> + Name -> + Q [Dec] +deriveUnifiedInterfaceExtra extraHandlers cls withFunc name = + deriveWithHandlers + ( extraHandlers + <> [ SomeDeriveTypeParamHandler TypeableMode, + SomeDeriveTypeParamHandler NatShouldBePositive, + SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls False + ] + ) + (UnifiedInstance cls withFunc withFunc Nothing) + True + 0 + [name] + +-- | Derive an instance for a unified interface. +deriveUnifiedInterface :: Name -> Name -> Name -> Q [Dec] +deriveUnifiedInterface = deriveUnifiedInterfaceExtra [] + +-- | Derive instances for a list of types for a unified interface. +deriveUnifiedInterfaces :: Name -> Name -> [Name] -> Q [Dec] +deriveUnifiedInterfaces cls withFunc = + fmap concat . mapM (deriveUnifiedInterface cls withFunc) + +-- | Derive an instance for a unified interface for functors, with extra +-- handlers. +deriveUnifiedInterface1Extra :: + [SomeDeriveTypeParamHandler] -> + Name -> + Name -> + Name -> + Name -> + Name -> + Q [Dec] +deriveUnifiedInterface1Extra extraHandlers cls withFunc cls1 withFunc1 name = + deriveWithHandlers + ( extraHandlers + <> [ SomeDeriveTypeParamHandler TypeableMode, + SomeDeriveTypeParamHandler NatShouldBePositive, + SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls False, + SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls1 False + ] + ) + (UnifiedInstance cls1 withFunc1 withFunc (Just withFunc1)) + True + 1 + [name] + +-- | Derive an instance for a unified interface for functors. +deriveUnifiedInterface1 :: + Name -> Name -> Name -> Name -> Name -> Q [Dec] +deriveUnifiedInterface1 = deriveUnifiedInterface1Extra [] + +-- | Derive instances for a list of types for a unified interface for functors. +deriveUnifiedInterface1s :: + Name -> Name -> Name -> Name -> [Name] -> Q [Dec] +deriveUnifiedInterface1s cls withFunc cls1 withFunc1 = + fmap concat . mapM (deriveUnifiedInterface1 cls withFunc cls1 withFunc1) + +-- | Derive an instance for a unified interface, with extra handlers. The type +-- being derived may have functor type parameters. +deriveFunctorArgUnifiedInterfaceExtra :: + [SomeDeriveTypeParamHandler] -> Name -> Name -> Name -> Name -> Name -> Q [Dec] +deriveFunctorArgUnifiedInterfaceExtra + extraHandlers + cls + withFunc + cls1 + withFunc1 + name = + deriveWithHandlers + ( extraHandlers + <> [ SomeDeriveTypeParamHandler TypeableMode, + SomeDeriveTypeParamHandler NatShouldBePositive, + SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls False, + SomeDeriveTypeParamHandler $ PrimaryUnifiedConstraint cls1 False + ] + ) + (UnifiedInstance cls withFunc withFunc (Just withFunc1)) + True + 0 + [name] + +-- | Derive an instance for a unified interface. The type being derived may have +-- functor type parameters. +deriveFunctorArgUnifiedInterface :: + Name -> Name -> Name -> Name -> Name -> Q [Dec] +deriveFunctorArgUnifiedInterface = deriveFunctorArgUnifiedInterfaceExtra [] + +-- | Derive instances for a list of types for a unified interface. The types +-- being derived may have functor type parameters. +deriveFunctorArgUnifiedInterfaces :: + Name -> Name -> Name -> Name -> [Name] -> Q [Dec] +deriveFunctorArgUnifiedInterfaces cls withFunc cls1 withFunc1 = + fmap concat + . mapM (deriveFunctorArgUnifiedInterface cls withFunc cls1 withFunc1) diff --git a/src/Grisette/Internal/TH/DeriveWithHandlers.hs b/src/Grisette/Internal/TH/DeriveWithHandlers.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/DeriveWithHandlers.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE TupleSections #-} + +-- | +-- Module : Grisette.Internal.TH.DeriveWithHandlers +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.DeriveWithHandlers + ( deriveWithHandlers, + ) +where + +import Control.Monad (foldM, unless, when) +import Data.List (transpose) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import Grisette.Internal.TH.DeriveInstanceProvider + ( DeriveInstanceProvider (instanceDeclaration), + ) +import Grisette.Internal.TH.DeriveTypeParamHandler + ( DeriveTypeParamHandler (handleBody, handleTypeParams), + SomeDeriveTypeParamHandler, + ) +import Grisette.Internal.TH.Util + ( allSameKind, + dropNTypeParam, + reifyDatatypeWithFreshNames, + substDataType, + ) +import Language.Haskell.TH (Dec, Name, Q) +import Language.Haskell.TH.Datatype + ( ConstructorInfo (constructorFields), + DatatypeInfo (datatypeCons, datatypeVars), + datatypeType, + reifyDatatype, + tvName, + ) + +transposeMatrix :: Int -> [[a]] -> [[a]] +transposeMatrix n [] = replicate n [] +transposeMatrix _ x = transpose x + +-- | Derive instances for a list of types with a list of handlers and a +-- provider. +deriveWithHandlers :: + (DeriveInstanceProvider provider) => + [SomeDeriveTypeParamHandler] -> + provider -> + Bool -> + Int -> + [Name] -> + Q [Dec] +deriveWithHandlers + handlers + provider + ignoreBodyConstraints + numDroppedTailTypes + names = do + when (numDroppedTailTypes < 0) $ + fail "deriveWithHandlers: numDroppedTailTypes must be non-negative" + when (numDroppedTailTypes > 0 && not ignoreBodyConstraints) $ + fail $ + "deriveWithHandlers: ignoreBodyConstraints must be True if " + <> "numDroppedTailTypes > 0" + when (null names) $ + fail "deriveWithHandlers: no types provided" + datatypes <- + if length names == 1 + then mapM reifyDatatype names + else mapM reifyDatatypeWithFreshNames names + + let tyVars = + transposeMatrix 0 $ + map + (reverse . drop numDroppedTailTypes . reverse . datatypeVars) + datatypes + unless (all allSameKind tyVars) $ + fail "deriveWithHandlers: all type variables must be aligned" + tyVarsWithConstraints <- + foldM + (flip $ handleTypeParams (length datatypes)) + ( map + (\tyVarList -> ((,Nothing) <$> tyVarList, Nothing)) + tyVars + ) + handlers + + let allTyVarsConstraints = + concatMap (fromMaybe [] . snd) tyVarsWithConstraints + let tvWithSubst = + transposeMatrix (length datatypes) $ + fst <$> tyVarsWithConstraints + + let substMaps = + map + ( M.fromList + . mapMaybe + ( \(tv, t) -> do + substTy <- t + return (tvName tv, substTy) + ) + ) + tvWithSubst + let substedTypes = zipWith substDataType datatypes substMaps + tys <- + mapM (dropNTypeParam numDroppedTailTypes . datatypeType) substedTypes + allConstraints <- + ( if ignoreBodyConstraints + then return allTyVarsConstraints + else do + bodyConstraints <- handleBodyWithHandlers substedTypes handlers + return $ allTyVarsConstraints ++ bodyConstraints + ) + instanceDeclaration + provider + (fst <$> tyVarsWithConstraints) + allConstraints + tys + where + handleBodyWithHandlers datatypes handlers = do + let cons = datatypeCons <$> datatypes + let zippedFields = zipFields cons + concat <$> traverse (`handleBody` zippedFields) handlers + zipFields cons = transpose $ concatMap constructorFields <$> cons diff --git a/src/Grisette/Internal/TH/MergeConstructor.hs b/src/Grisette/Internal/TH/MergeConstructor.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/MergeConstructor.hs @@ -0,0 +1,147 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Grisette.Internal.TH.MergedConstructor +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.MergeConstructor + ( mkMergeConstructor, + mkMergeConstructor', + ) +where + +import Control.Monad (join, replicateM, when, zipWithM) +import Data.Bifunctor (Bifunctor (second)) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Internal.TH.Util (constructorInfoToType, occName, putHaddock) +import Language.Haskell.TH + ( Body (NormalB), + Clause (Clause), + Dec (FunD, SigD), + Exp (AppE, ConE, LamE, VarE), + Name, + Pat (VarP), + Pred, + Q, + Type (AppT, ArrowT, ForallT, VarT), + mkName, + newName, + ) +import Language.Haskell.TH.Datatype + ( ConstructorInfo + ( constructorFields, + constructorName + ), + DatatypeInfo (datatypeCons), + reifyDatatype, + ) +import Language.Haskell.TH.Datatype.TyVarBndr + ( Specificity (SpecifiedSpec), + TyVarBndrSpec, + plainTVFlag, + ) + +-- | Generate constructor wrappers that wraps the result in a container with +-- `TryMerge` with provided names. +-- +-- > mkMergeConstructor' ["mrgTuple2"] ''(,) +-- +-- generates +-- +-- > mrgTuple2 :: (Mergeable (a, b), Applicative m, TryMerge m) => a -> b -> u (a, b) +-- > mrgTuple2 = \v1 v2 -> mrgSingle (v1, v2) +mkMergeConstructor' :: + -- | Names for generated wrappers + [String] -> + -- | The type to generate the wrappers for + Name -> + Q [Dec] +mkMergeConstructor' names typName = do + d <- reifyDatatype typName + let constructors = datatypeCons d + when (length names /= length constructors) $ + fail "Number of names does not match the number of constructors" + ds <- zipWithM (mkSingleWrapper d) names constructors + return $ join ds + +-- | Generate constructor wrappers that wraps the result in a container with +-- `TryMerge`. +-- +-- > mkMergeConstructor "mrg" ''Maybe +-- +-- generates +-- +-- > mrgJust :: (Mergeable (Maybe a), Applicative m, TryMerge m) => m (Maybe a) +-- > mrgNothing = mrgSingle Nothing +-- > mrgJust :: (Mergeable (Maybe a), Applicative m, TryMerge m) => a -> m (Maybe a) +-- > mrgJust = \x -> mrgSingle (Just x) +mkMergeConstructor :: + -- | Prefix for generated wrappers + String -> + -- | The type to generate the wrappers for + Name -> + Q [Dec] +mkMergeConstructor prefix typName = do + d <- reifyDatatype typName + let constructorNames = occName . constructorName <$> datatypeCons d + mkMergeConstructor' ((prefix ++) <$> constructorNames) typName + +augmentNormalCExpr :: Int -> Exp -> Q Exp +augmentNormalCExpr n f = do + xs <- replicateM n (newName "x") + let args = map VarP xs + mrgSingleFun <- [|mrgSingle|] + return $ + LamE + args + ( AppE mrgSingleFun $ + foldl AppE f (map VarE xs) + ) + +augmentFinalType :: Type -> Q (([TyVarBndrSpec], [Pred]), Type) +augmentFinalType (AppT a@(AppT ArrowT _) t) = do + tl <- augmentFinalType t + return $ second (AppT a) tl +augmentFinalType t = do + mName <- newName "m" + let mTy = VarT mName + mergeable <- [t|Mergeable|] + applicative <- [t|Applicative|] + tryMerge <- [t|TryMerge|] + return + ( ( [plainTVFlag mName SpecifiedSpec], + [AppT mergeable t, AppT applicative mTy, AppT tryMerge mTy] + ), + AppT mTy t + ) + +augmentConstructorType :: Type -> Q Type +augmentConstructorType (ForallT tybinders ctx ty1) = do + ((bndrs, preds), augmentedTyp) <- augmentFinalType ty1 + return $ ForallT (tybinders ++ bndrs) (preds ++ ctx) augmentedTyp +augmentConstructorType t = do + ((bndrs, preds), augmentedTyp) <- augmentFinalType t + return $ ForallT bndrs preds augmentedTyp + +mkSingleWrapper :: DatatypeInfo -> String -> ConstructorInfo -> Q [Dec] +mkSingleWrapper dataType name info = do + constructorTyp <- constructorInfoToType dataType info + augmentedTyp <- augmentConstructorType constructorTyp + let oriName = constructorName info + let retName = mkName name + expr <- augmentNormalCExpr (length $ constructorFields info) (ConE oriName) + putHaddock retName $ + "Smart constructor for v'" + <> show oriName + <> "' to construct values wrapped and possibly merged in a container." + return + [ SigD retName augmentedTyp, + FunD retName [Clause [] (NormalB expr) []] + ] diff --git a/src/Grisette/Internal/TH/UnifiedConstructor.hs b/src/Grisette/Internal/TH/UnifiedConstructor.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/UnifiedConstructor.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | +-- Module : Grisette.Internal.TH.UnifiedConstructor +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.UnifiedConstructor + ( mkUnifiedConstructor, + mkUnifiedConstructor', + ) +where + +import Control.Monad (join, replicateM, when, zipWithM) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.TH.Util (constructorInfoToType, occName, putHaddock) +import Grisette.Unified.Internal.EvalMode (EvalMode) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag) +import Grisette.Unified.Internal.UnifiedData + ( GetData, + UnifiedData, + wrapData, + ) +import Language.Haskell.TH.Datatype + ( ConstructorInfo (constructorFields, constructorName), + DatatypeInfo (datatypeCons, datatypeVars), + reifyDatatype, + tvKind, + tvName, + ) +import Language.Haskell.TH.Lib (appE, appTypeE, lamE, varE, varP) +import Language.Haskell.TH.Syntax + ( Body (NormalB), + Clause (Clause), + Dec (FunD, SigD), + Exp (ConE), + Name, + Pred, + Q, + Type (AppT, ArrowT, ConT, ForallT, VarT), + mkName, + newName, + ) + +-- | Generate smart constructors to create unified values. +-- +-- For a type @T mode a b c@ with constructors @T1@, @T2@, etc., this function +-- will generate smart constructors with the given prefix, e.g., @mkT1@, @mkT2@, +-- etc. +-- +-- The generated smart constructors will contruct values of type +-- @GetData mode (T mode a b c)@. +mkUnifiedConstructor :: + -- | Prefix for generated wrappers + String -> + -- | The type to generate the wrappers for + Name -> + Q [Dec] +mkUnifiedConstructor prefix typName = do + d <- reifyDatatype typName + let constructorNames = occName . constructorName <$> datatypeCons d + mkUnifiedConstructor' ((prefix ++) <$> constructorNames) typName + +-- | Generate smart constructors to create unified values. +-- +-- For a type @T mode a b c@ with constructors @T1@, @T2@, etc., this function +-- will generate smart constructors with the given names. +-- +-- The generated smart constructors will contruct values of type +-- @GetData mode (T mode a b c)@. +mkUnifiedConstructor' :: + -- | Names for generated wrappers + [String] -> + -- | The type to generate the wrappers for + Name -> + Q [Dec] +mkUnifiedConstructor' names typName = do + d <- reifyDatatype typName + let constructors = datatypeCons d + when (length names /= length constructors) $ + fail "Number of names does not match the number of constructors" + let modeVars = filter ((== ConT ''EvalModeTag) . tvKind) (datatypeVars d) + when (length modeVars /= 1) $ + fail "Expected exactly one EvalModeTag variable in the datatype." + case modeVars of + [mode] -> do + ds <- zipWithM (mkSingleWrapper d $ VarT $ tvName mode) names constructors + return $ join ds + _ -> fail "Expected exactly one EvalModeTag variable in the datatype." + +augmentFinalType :: Type -> Type -> Q ([Pred], Type) +augmentFinalType mode (AppT a@(AppT ArrowT _) t) = do + (pred, ret) <- augmentFinalType mode t + return (pred, AppT a ret) +augmentFinalType mode t = do + r <- [t|GetData $(return mode) $(return t)|] + pred <- [t|Mergeable $(return t)|] + predu <- [t|UnifiedData $(return mode) $(return t)|] + return ([pred, predu], r) + +augmentConstructorType :: Type -> Type -> Q Type +augmentConstructorType mode (ForallT tybinders ctx ty1) = do + (preds, augmentedTyp) <- augmentFinalType mode ty1 + ismode <- [t|EvalMode $(return mode)|] + return $ ForallT tybinders (ismode : preds ++ ctx) augmentedTyp +augmentConstructorType _ _ = + fail + "augmentConstructorType: unsupported constructor, must be a forall type." + +augmentExpr :: Type -> Int -> Exp -> Q Exp +augmentExpr mode n f = do + xs <- replicateM n (newName "x") + let args = map varP xs + lamE + args + ( ( appE + (appTypeE [|wrapData|] (return mode)) + (foldl appE (return f) (map varE xs)) + ) + ) + +mkSingleWrapper :: DatatypeInfo -> Type -> String -> ConstructorInfo -> Q [Dec] +mkSingleWrapper dataType mode name info = do + constructorTyp <- constructorInfoToType dataType info + augmentedTyp <- augmentConstructorType mode constructorTyp + let oriName = constructorName info + let retName = mkName name + expr <- augmentExpr mode (length $ constructorFields info) (ConE oriName) + putHaddock retName $ + "Smart constructor for v'" + <> show oriName + <> "' to construct unified value." + return + [ SigD retName augmentedTyp, + FunD retName [Clause [] (NormalB expr) []] + ] diff --git a/src/Grisette/Internal/TH/Util.hs b/src/Grisette/Internal/TH/Util.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/TH/Util.hs @@ -0,0 +1,242 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} + +-- | +-- Module : Grisette.Internal.TH.Util +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.TH.Util + ( occName, + constructorInfoToType, + tvIsMode, + tvIsNat, + tvIsStar, + tvIsStarToStar, + substDataType, + reifyDatatypeWithFreshNames, + singleParamClassParamKind, + binaryClassParamKind, + getTypeWithMaybeSubst, + dropLastTypeParam, + dropNTypeParam, + classParamKinds, + allSameKind, + classNumParam, + kindNumParam, + concatPreds, + putHaddock, + ) +where + +#if MIN_VERSION_template_haskell(2,18,0) +import Language.Haskell.TH.Syntax (addModFinalizer, putDoc, DocLoc(DeclDoc)) +#endif + +import Control.Monad (when) +import qualified Data.Map as M +import GHC.TypeNats (Nat) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag) +import Language.Haskell.TH + ( Dec (ClassD), + Info (ClassI), + Kind, + Name, + Pred, + Q, + Type (AppT, ArrowT, ConT, ForallT, StarT, VarT), + newName, + pprint, + reify, + varT, + ) +import Language.Haskell.TH.Datatype + ( ConstructorInfo (constructorContext, constructorFields, constructorVars), + DatatypeInfo (datatypeCons, datatypeInstTypes, datatypeVars), + TypeSubstitution (applySubstitution), + datatypeType, + reifyDatatype, + tvName, + ) +import Language.Haskell.TH.Datatype.TyVarBndr + ( Specificity (SpecifiedSpec), + TyVarBndrUnit, + TyVarBndr_, + mapTVFlag, + mapTVName, + tvKind, + ) +import Language.Haskell.TH.Syntax (Name (Name), OccName (OccName)) + +-- | Get the unqualified name of a 'Name'. +occName :: Name -> String +occName (Name (OccName name) _) = name + +-- | Convert a 'ConstructorInfo' to a 'Type' of the constructor. +constructorInfoToType :: DatatypeInfo -> ConstructorInfo -> Q Type +constructorInfoToType dataType info = do + let binders = + mapTVFlag (const SpecifiedSpec) + <$> datatypeVars dataType ++ constructorVars info + let ctx = constructorContext info + let fields = constructorFields info + let tyBody = + foldr (AppT . AppT ArrowT) (datatypeType dataType) fields + if null binders then return tyBody else return $ ForallT binders ctx tyBody + +-- | Check if a type variable is of kind 'EvalModeTag'. +tvIsMode :: TyVarBndr_ flag -> Bool +tvIsMode = (== ConT ''EvalModeTag) . tvKind + +-- | Check if a type variable is of kind 'Nat'. +tvIsNat :: TyVarBndr_ flag -> Bool +tvIsNat = (== ConT ''Nat) . tvKind + +-- | Check if a type variable is of kind 'Data.Kind.Type'. +tvIsStar :: TyVarBndr_ flag -> Bool +tvIsStar = (== StarT) . tvKind + +-- | Check if a type variable is of kind 'Data.Kind.Type -> Data.Kind.Type'. +tvIsStarToStar :: TyVarBndr_ flag -> Bool +tvIsStarToStar = (== (AppT (AppT ArrowT StarT) StarT)) . tvKind + +-- | Substitute the type variables in a 'DatatypeInfo' with the given +-- substitution map. +substDataType :: DatatypeInfo -> M.Map Name Type -> DatatypeInfo +substDataType d substMap = + d + { datatypeInstTypes = applySubstitution substMap <$> datatypeInstTypes d, + datatypeCons = applySubstitution substMap <$> datatypeCons d + } + +-- | Convert a 'DatatypeInfo' to a 'DatatypeInfo' with fresh type variable +-- names. +datatypeToFreshNames :: DatatypeInfo -> Q DatatypeInfo +datatypeToFreshNames d = do + let vars = datatypeVars d + let names = tvName <$> vars + freshNames <- traverse (newName . show) names + let newDTVars = zipWith (\v n -> mapTVName (const n) v) vars freshNames + let substMap = M.fromList $ zip names (VarT <$> freshNames) + return $ substDataType d {datatypeVars = newDTVars} substMap + +-- | Reify a datatype with fresh type variable names. +reifyDatatypeWithFreshNames :: Name -> Q DatatypeInfo +reifyDatatypeWithFreshNames name = do + d <- reifyDatatype name + datatypeToFreshNames d + +-- | Check if all type variables have the same kind. +allSameKind :: [TyVarBndrUnit] -> Bool +allSameKind [] = True +allSameKind (x : xs) = all ((== tvKind x) . tvKind) xs + +-- | Get the kinds of the type parameters of a class. +classParamKinds :: Name -> Q [Kind] +classParamKinds className = do + cls <- reify className + case cls of + ClassI (ClassD _ _ bndrs _ _) _ -> return $ tvKind <$> bndrs + _ -> + fail $ + "symmetricClassParamKind:" <> show className <> " is not a class" + +-- | Get the number of type parameters of a class. +classNumParam :: Name -> Q Int +classNumParam className = do + cls <- reify className + case cls of + ClassI (ClassD _ _ bndrs _ _) _ -> return $ length bndrs + _ -> + fail $ + "classNumParam:" <> show className <> " is not a class" + +-- | Get the kind of the single type parameter of a class. +singleParamClassParamKind :: Name -> Q Kind +singleParamClassParamKind className = do + cls <- reify className + case cls of + ClassI (ClassD _ _ bndrs _ _) _ -> + case bndrs of + [x] -> return $ tvKind x + _ -> + fail $ + "singleParamClassParamKind: only support classes with one type " + <> "parameter, but " + <> show className + <> " has " + <> show (length bndrs) + _ -> + fail $ + "singleParamClassParamKind:" <> show className <> " is not a class" + +-- | Get the kind of the binary type parameter of a class. +binaryClassParamKind :: Name -> Q Kind +binaryClassParamKind className = do + cls <- reify className + case cls of + ClassI (ClassD _ _ bndrs _ _) _ -> + case bndrs of + [x, y] -> do + when (tvKind x /= tvKind y) $ + fail "binaryClassParamKind: type parameters have different kinds" + return $ tvKind x + _ -> + fail $ + "binaryClassParamKind: only support classes with two type " + <> "parameters, but " + <> show className + <> " has " + <> show (length bndrs) + _ -> + fail $ + "binaryClassParamKind:" <> show className <> " is not a class" + +-- | Get a type with a possible substitution. +getTypeWithMaybeSubst :: TyVarBndrUnit -> Maybe Type -> Q Type +getTypeWithMaybeSubst tv Nothing = varT $ tvName tv +getTypeWithMaybeSubst _ (Just t) = return t + +-- | Drop the last instantiated type parameter of a type. +dropLastTypeParam :: Type -> Q Type +dropLastTypeParam (AppT c _) = return c +dropLastTypeParam v = + fail $ + "dropLastTypeParam: have no type parameters: " + <> pprint v + <> " / " + <> show v + +-- | Drop the last N instantiated type parameters of a type. +dropNTypeParam :: Int -> Type -> Q Type +dropNTypeParam 0 t = return t +dropNTypeParam n t = dropLastTypeParam t >>= dropNTypeParam (n - 1) + +-- | Get the number of type parameters of a kind. +kindNumParam :: Kind -> Q Int +kindNumParam (AppT (AppT ArrowT _) k) = (1 +) <$> kindNumParam k +kindNumParam _ = return 0 + +-- | Concatenate two 'Maybe [Pred]'. +concatPreds :: Maybe [Pred] -> Maybe [Pred] -> Maybe [Pred] +concatPreds Nothing Nothing = Nothing +concatPreds (Just ps) Nothing = Just ps +concatPreds Nothing (Just ps) = Just ps +concatPreds (Just ps1) (Just ps2) = Just $ ps1 ++ ps2 + +#if MIN_VERSION_template_haskell(2,18,0) +-- | Put a haddock comment on a declaration. +putHaddock :: Name -> String -> Q () +putHaddock name = addModFinalizer . putDoc (DeclDoc name) +#else +-- | Put a haddock comment on a declaration. +-- (No-op because compiling with GHC < 9.2) +putHaddock :: Name -> String -> Q () +putHaddock _ _ = return () +#endif diff --git a/src/Grisette/Internal/Utils/Derive.hs b/src/Grisette/Internal/Utils/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Internal/Utils/Derive.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | +-- Module : Grisette.Internal.Utils.Derive +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Internal.Utils.Derive (Arity0, Arity1) where + +-- | Type-level tag for generic derivation with arity 0. +data Arity0 + +-- | Type-level tag for generic derivation with arity 1. +data Arity1 diff --git a/src/Grisette/Internal/Utils/Parameterized.hs b/src/Grisette/Internal/Utils/Parameterized.hs --- a/src/Grisette/Internal/Utils/Parameterized.hs +++ b/src/Grisette/Internal/Utils/Parameterized.hs @@ -114,6 +114,7 @@ unsafeAxiom :: forall a b. a :~: b unsafeAxiom = unsafeCoerce (Refl @a) +-- | Construct the 'KnownNat' constraint when the runtime value is known. withKnownNat :: forall n r. NatRepr n -> ((KnownNat n) => r) -> r withKnownNat (NatRepr nVal) v = case someNatVal nVal of @@ -132,6 +133,7 @@ data SomeNatReprHelper where SomeNatReprHelper :: NatRepr n -> SomeNatReprHelper +-- | Existential wrapper for 'NatRepr'. data SomeNatRepr where SomeNatRepr :: (KnownNat n) => NatRepr n -> SomeNatRepr @@ -141,6 +143,8 @@ mkNatRepr n = case SomeNatReprHelper (NatRepr n) of SomeNatReprHelper natRepr -> withKnownNat natRepr $ SomeNatRepr natRepr +-- | Existential wrapper for 'NatRepr' with the constraint that the natural +-- number is greater than 0. data SomePositiveNatRepr where SomePositiveNatRepr :: (KnownNat n, 1 <= n) => NatRepr n -> SomePositiveNatRepr diff --git a/src/Grisette/Lib/Control/Applicative.hs b/src/Grisette/Lib/Control/Applicative.hs --- a/src/Grisette/Lib/Control/Applicative.hs +++ b/src/Grisette/Lib/Control/Applicative.hs @@ -32,28 +32,21 @@ ) where -import Control.Applicative (Alternative (empty, (<|>)), (<**>)) -import Data.Functor (void) -import Grisette.Internal.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), - MergingStrategy, - ) -import Grisette.Internal.Core.Data.Class.TryMerge - ( TryMerge, - mrgSingleWithStrategy, - tryMerge, - ) +import Control.Applicative (Alternative) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable, MergingStrategy) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) import Grisette.Lib.Data.Functor ((.<$), (.<$>)) +import qualified Grisette.Unified.Lib.Control.Applicative as Unified --- | Alias for 'mrgSingleWithStrategy'. +-- | Alias for 'Grisette.Core.mrgSingleWithStrategy'. mrgPureWithStrategy :: (TryMerge m, Applicative m) => MergingStrategy a -> a -> m a -mrgPureWithStrategy = mrgSingleWithStrategy +mrgPureWithStrategy = Unified.mrgPureWithStrategy {-# INLINE mrgPureWithStrategy #-} --- | Alias for 'mrgSingle'. +-- | Alias for 'Grisette.Core.mrgSingle'. mrgPure :: (TryMerge m, Applicative m, Mergeable a) => a -> m a -mrgPure = mrgPureWithStrategy rootStrategy +mrgPure = Unified.mrgPure {-# INLINE mrgPure #-} infixl 4 .<*> @@ -64,7 +57,7 @@ f (a -> b) -> f a -> f b -f .<*> a = tryMerge $ tryMerge f <*> tryMerge a +(.<*>) = (Unified..<*>) {-# INLINE (.<*>) #-} -- | 'liftA2' with 'MergingStrategy' knowledge propagation. @@ -74,7 +67,7 @@ f a -> f b -> f c -mrgLiftA2 f a b = f .<$> a .<*> tryMerge b +mrgLiftA2 = Unified.mrgLiftA2 {-# INLINE mrgLiftA2 #-} infixl 4 .*> @@ -82,7 +75,7 @@ -- | '*>' with 'MergingStrategy' knowledge propagation. (.*>) :: (Applicative f, TryMerge f, Mergeable a, Mergeable b) => f a -> f b -> f b -a .*> b = tryMerge $ tryMerge (void a) *> tryMerge b +(.*>) = (Unified..*>) {-# INLINE (.*>) #-} infixl 4 .<* @@ -90,58 +83,52 @@ -- | '<*' with 'MergingStrategy' knowledge propagation. (.<*) :: (Applicative f, TryMerge f, Mergeable a, Mergeable b) => f a -> f b -> f a -a .<* b = tryMerge $ tryMerge a <* tryMerge (void b) +(.<*) = (Unified..<*) {-# INLINE (.<*) #-} --- | 'empty' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Applicative.empty' with 'MergingStrategy' knowledge propagation. mrgEmpty :: (Alternative f, TryMerge f, Mergeable a) => f a -mrgEmpty = tryMerge empty +mrgEmpty = Unified.mrgEmpty {-# INLINE mrgEmpty #-} infixl 3 .<|> --- | '<|>' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Applicative.<|>' with 'MergingStrategy' knowledge propagation. (.<|>) :: (Alternative f, TryMerge f, Mergeable a) => f a -> f a -> f a -a .<|> b = tryMerge $ tryMerge a <|> tryMerge b +(.<|>) = (Unified..<|>) {-# INLINE (.<|>) #-} --- | 'some' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Applicative.some' with 'MergingStrategy' knowledge propagation. mrgSome :: (Alternative f, TryMerge f, Mergeable a) => f a -> f [a] -mrgSome v = some_v - where - many_v = some_v .<|> pure [] - some_v = mrgLiftA2 (:) v many_v +mrgSome = Unified.mrgSome {-# INLINE mrgSome #-} --- | 'many' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Applicative.many' with 'MergingStrategy' knowledge propagation. mrgMany :: (Alternative f, TryMerge f, Mergeable a) => f a -> f [a] -mrgMany v = many_v - where - many_v = some_v .<|> pure [] - some_v = mrgLiftA2 (:) v many_v +mrgMany = Unified.mrgMany {-# INLINE mrgMany #-} infixl 4 .<**> --- | '<**>' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Applicative.<**>' with 'MergingStrategy' knowledge propagation. (.<**>) :: (Applicative f, TryMerge f, Mergeable a, Mergeable b) => f a -> f (a -> b) -> f b -a .<**> f = tryMerge $ tryMerge a <**> tryMerge f +(.<**>) = (Unified..<**>) {-# INLINE (.<**>) #-} --- | 'liftA' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Applicative.liftA' with 'MergingStrategy' knowledge propagation. mrgLiftA :: (Applicative f, TryMerge f, Mergeable a, Mergeable b) => (a -> b) -> f a -> f b -mrgLiftA f a = mrgPure f .<*> a +mrgLiftA = Unified.mrgLiftA {-# INLINE mrgLiftA #-} --- | 'liftA3' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Applicative.liftA3' with 'MergingStrategy' knowledge propagation. mrgLiftA3 :: ( Applicative f, TryMerge f, @@ -155,19 +142,20 @@ f b -> f c -> f d -mrgLiftA3 f a b c = mrgPure f .<*> a .<*> b .<*> c +mrgLiftA3 = Unified.mrgLiftA3 {-# INLINE mrgLiftA3 #-} --- | 'optional' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Applicative.optional' with 'MergingStrategy' knowledge +-- propagation. mrgOptional :: (Alternative f, TryMerge f, Mergeable a) => f a -> f (Maybe a) -mrgOptional v = Just .<$> v .<|> pure Nothing +mrgOptional = Unified.mrgOptional {-# INLINE mrgOptional #-} --- | 'asum' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Applicative.asum' with 'MergingStrategy' knowledge propagation. mrgAsum :: (Alternative f, TryMerge f, Mergeable a, Foldable t) => t (f a) -> f a -mrgAsum = foldr (.<|>) mrgEmpty +mrgAsum = Unified.mrgAsum {-# INLINE mrgAsum #-} diff --git a/src/Grisette/Lib/Control/Monad.hs b/src/Grisette/Lib/Control/Monad.hs --- a/src/Grisette/Lib/Control/Monad.hs +++ b/src/Grisette/Lib/Control/Monad.hs @@ -1,8 +1,10 @@ {-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Grisette.Lib.Control.Monad @@ -79,49 +81,37 @@ where import Control.Applicative (Alternative) -import Control.Monad (MonadPlus (mplus, mzero), join) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||))) +import Control.Monad (MonadPlus) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) import Grisette.Internal.Core.Data.Class.Mergeable - ( Mergeable (rootStrategy), + ( Mergeable, MergingStrategy, ) -import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<=))) -import Grisette.Internal.Core.Data.Class.SimpleMergeable (UnionMergeable1, mrgIf) +import Grisette.Internal.Core.Data.Class.SimpleMergeable (SymBranching) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd) import Grisette.Internal.Core.Data.Class.TryMerge ( MonadTryMerge, - TryMerge (tryMergeWithStrategy), - tryMerge, + TryMerge, ) import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Lib.Control.Applicative - ( mrgEmpty, - mrgLiftA2, - mrgPure, - (.*>), - (.<$>), - (.<*>), - ) import Grisette.Lib.Data.Foldable - ( mrgFoldlM, - mrgForM_, + ( mrgForM_, mrgMapM_, mrgMsum, - mrgSequenceA_, mrgSequence_, ) -import Grisette.Lib.Data.Functor (mrgFmap, mrgUnzip, mrgVoid, (.<$)) +import Grisette.Lib.Data.Functor (mrgFmap, mrgVoid, (.<$)) import Grisette.Lib.Data.Traversable ( mrgForM, mrgMapM, mrgSequence, - mrgSequenceA, - mrgTraverse, ) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Sym)) +import qualified Grisette.Unified.Lib.Control.Monad as Unified -- | 'return' with 'MergingStrategy' knowledge propagation. mrgReturnWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> a -> u a -mrgReturnWithStrategy s = tryMergeWithStrategy s . return +mrgReturnWithStrategy = Unified.mrgReturnWithStrategy {-# INLINE mrgReturnWithStrategy #-} -- | '>>=' with 'MergingStrategy' knowledge propagation. @@ -132,13 +122,12 @@ u a -> (a -> u b) -> u b -mrgBindWithStrategy sa sb a f = - tryMergeWithStrategy sb $ tryMergeWithStrategy sa a >>= f +mrgBindWithStrategy = Unified.mrgBindWithStrategy {-# INLINE mrgBindWithStrategy #-} -- | 'return' with 'MergingStrategy' knowledge propagation. mrgReturn :: (MonadTryMerge u, Mergeable a) => a -> u a -mrgReturn = mrgReturnWithStrategy rootStrategy +mrgReturn = Unified.mrgReturn {-# INLINE mrgReturn #-} infixl 1 .>>= @@ -149,7 +138,7 @@ u a -> (a -> u b) -> u b -(.>>=) = mrgBindWithStrategy rootStrategy rootStrategy +(.>>=) = (Unified..>>=) {-# INLINE (.>>=) #-} infixl 1 .>> @@ -159,23 +148,23 @@ -- This is usually more efficient than calling the original '>>' and merge the -- results. (.>>) :: (MonadTryMerge m, Mergeable a, Mergeable b) => m a -> m b -> m b -a .>> f = tryMerge $ mrgVoid a >> f +(.>>) = (Unified..>>) {-# INLINE (.>>) #-} -- | 'fail' with 'MergingStrategy' knowledge propagation. mrgFail :: (MonadTryMerge m, Mergeable a, MonadFail m) => String -> m a -mrgFail = tryMerge . fail +mrgFail = Unified.mrgFail {-# INLINE mrgFail #-} --- | 'mzero' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.mzero' with 'MergingStrategy' knowledge propagation. mrgMzero :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a -mrgMzero = tryMerge mzero +mrgMzero = Unified.mrgMzero {-# INLINE mrgMzero #-} --- | 'mplus' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.mplus' with 'MergingStrategy' knowledge propagation. mrgMplus :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a -> m a -> m a -mrgMplus a b = tryMerge $ mplus (tryMerge a) (tryMerge b) +mrgMplus = Unified.mrgMplus {-# INLINE mrgMplus #-} infixr 1 .=<< @@ -183,96 +172,83 @@ -- | '=<<' with 'MergingStrategy' knowledge propagation. (.=<<) :: (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> m b) -> m a -> m b -f .=<< a = tryMerge $ f =<< tryMerge a +(.=<<) = (Unified..=<<) {-# INLINE (.=<<) #-} infixr 1 .>=> --- | '>=>' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.>=>' with 'MergingStrategy' knowledge propagation. (.>=>) :: (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) => (a -> m b) -> (b -> m c) -> a -> m c -f .>=> g = \a -> tryMerge $ tryMerge (f a) >>= g +(.>=>) = (Unified..>=>) {-# INLINE (.>=>) #-} infixr 1 .<=< --- | '<=<' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.<=<' with 'MergingStrategy' knowledge propagation. (.<=<) :: (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) => (b -> m c) -> (a -> m b) -> a -> m c -(.<=<) = flip (.>=>) +(.<=<) = (Unified..<=<) {-# INLINE (.<=<) #-} --- | 'forever' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.forever' with 'MergingStrategy' knowledge propagation. mrgForever :: (Applicative m, TryMerge m, Mergeable b, Mergeable a) => m a -> m b -mrgForever a = let a' = a .*> a' in a' +mrgForever = Unified.mrgForever {-# INLINE mrgForever #-} --- | 'join' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.join' with 'MergingStrategy' knowledge propagation. mrgJoin :: (MonadTryMerge m, Mergeable a) => m (m a) -> m a -mrgJoin a = tryMerge $ join a +mrgJoin = Unified.mrgJoin {-# INLINE mrgJoin #-} --- | 'mfilter' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.mfilter' with 'MergingStrategy' knowledge propagation. mrgMfilter :: (MonadTryMerge m, MonadPlus m, Mergeable a) => (a -> Bool) -> m a -> m a -mrgMfilter p ma = do - a <- tryMerge ma - if p a then mrgReturn a else mrgMzero +mrgMfilter = Unified.mrgMfilter {-# INLINE mrgMfilter #-} --- | 'mfilter' with 'MergingStrategy' knowledge propagation and symbolic --- conditions. +-- | 'Control.Monad.mfilter' with 'MergingStrategy' knowledge propagation and +-- symbolic conditions. symMfilter :: (MonadTryMerge m, MonadPlus m, MonadUnion m, Mergeable a) => (a -> SymBool) -> m a -> m a -symMfilter p ma = do - a <- tryMerge ma - mrgIf (p a) (mrgReturn a) mrgMzero +symMfilter = Unified.symMfilter {-# INLINE symMfilter #-} --- | 'filterM' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.filterM' with 'MergingStrategy' knowledge propagation. mrgFilterM :: (TryMerge m, Applicative m, Mergeable a, Foldable t) => (a -> m Bool) -> t a -> m [a] -mrgFilterM p = - foldr - (\x lst -> (\flg -> if flg then (x :) else id) .<$> p x .<*> lst) - (mrgPure []) +mrgFilterM = Unified.mrgFilterM {-# INLINE mrgFilterM #-} --- | 'filterM' with 'MergingStrategy' knowledge propagation and symbolic --- conditions. +-- | 'Control.Monad.filterM' with 'MergingStrategy' knowledge propagation and +-- symbolic conditions. symFilterM :: (TryMerge m, MonadUnion m, Mergeable a, Foldable t) => (a -> m SymBool) -> t a -> m [a] -symFilterM p = - foldr - ( \x lst -> do - flag <- tryMerge $ p x - mrgIf flag ((x :) <$> lst) lst - ) - (mrgPure []) +symFilterM = Unified.symFilterM {-# INLINE symFilterM #-} --- | 'mapAndUnzipM' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.mapAndUnzipM' with 'MergingStrategy' knowledge propagation. mrgMapAndUnzipM :: ( Applicative m, TryMerge m, @@ -282,157 +258,141 @@ (a -> m (b, c)) -> [a] -> m ([b], [c]) -mrgMapAndUnzipM f xs = mrgUnzip .<$> mrgTraverse f xs +mrgMapAndUnzipM = Unified.mrgMapAndUnzipM {-# INLINE mrgMapAndUnzipM #-} --- | 'zipWithM' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.zipWithM' with 'MergingStrategy' knowledge propagation. mrgZipWithM :: (Applicative m, TryMerge m, Mergeable c) => (a -> b -> m c) -> [a] -> [b] -> m [c] -mrgZipWithM f xs ys = mrgSequenceA (zipWith f xs ys) +mrgZipWithM = Unified.mrgZipWithM {-# INLINE mrgZipWithM #-} --- | 'zipWithM_' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.zipWithM_' with 'MergingStrategy' knowledge propagation. mrgZipWithM_ :: (Applicative m, TryMerge m, Mergeable c) => (a -> b -> m c) -> [a] -> [b] -> m () -mrgZipWithM_ f xs ys = mrgSequenceA_ (zipWith f xs ys) +mrgZipWithM_ = Unified.mrgZipWithM_ {-# INLINE mrgZipWithM_ #-} --- | 'foldM' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.foldM' with 'MergingStrategy' knowledge propagation. mrgFoldM :: (MonadTryMerge m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b -mrgFoldM = mrgFoldlM +mrgFoldM = Unified.mrgFoldM {-# INLINE mrgFoldM #-} --- | 'foldM_' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.foldM_' with 'MergingStrategy' knowledge propagation. mrgFoldM_ :: (MonadTryMerge m, Foldable t, Mergeable b) => (b -> a -> m b) -> b -> t a -> m () -mrgFoldM_ f a xs = mrgFoldlM f a xs .>> mrgPure () +mrgFoldM_ = Unified.mrgFoldM_ {-# INLINE mrgFoldM_ #-} --- | 'replicateM' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.replicateM' with 'MergingStrategy' knowledge propagation. mrgReplicateM :: (Applicative m, TryMerge m, Mergeable a) => Int -> m a -> m [a] -mrgReplicateM n = mrgSequenceA . replicate n +mrgReplicateM = Unified.mrgReplicateM {-# INLINE mrgReplicateM #-} --- | 'replicateM' with 'MergingStrategy' knowledge propagation and symbolic --- number of elements. +-- | 'Control.Monad.replicateM' with 'MergingStrategy' knowledge propagation and +-- symbolic number of elements. symReplicateM :: - (MonadUnion m, TryMerge m, Mergeable a, Num int, SOrd int) => + (MonadUnion m, TryMerge m, Mergeable a, Num int, SymOrd int) => Int -> int -> m a -> m [a] -symReplicateM maxCnt cnt0 f = - loop maxCnt cnt0 - where - loop concreteCnt cnt = - mrgIf - (cnt .<= 0 .|| concreteCnt .<= 0) - (mrgPure []) - (mrgLiftA2 (:) f (loop (concreteCnt - 1) (cnt - 1))) +symReplicateM = Unified.symReplicateM @'Sym {-# INLINE symReplicateM #-} --- | 'replicateM_' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.replicateM_' with 'MergingStrategy' knowledge propagation. mrgReplicateM_ :: (Applicative m, TryMerge m, Mergeable a) => Int -> m a -> m () -mrgReplicateM_ n = mrgSequenceA_ . replicate n +mrgReplicateM_ = Unified.mrgReplicateM_ {-# INLINE mrgReplicateM_ #-} --- | 'replicateM_' with 'MergingStrategy' knowledge propagation and symbolic --- number of elements. +-- | 'Control.Monad.replicateM_' with 'MergingStrategy' knowledge propagation +-- and symbolic number of elements. symReplicateM_ :: - (MonadUnion m, TryMerge m, Mergeable a, Num int, SOrd int) => + (MonadUnion m, TryMerge m, Mergeable a, Num int, SymOrd int) => Int -> int -> m a -> m () -symReplicateM_ maxCnt cnt0 f = - loop maxCnt cnt0 - where - loop concreteCnt cnt = - mrgIf - (cnt .<= 0 .|| concreteCnt .<= 0) - (mrgPure ()) - (f .*> (loop (concreteCnt - 1) (cnt - 1))) +symReplicateM_ = Unified.symReplicateM_ @'Sym {-# INLINE symReplicateM_ #-} --- | 'guard' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.guard' with 'MergingStrategy' knowledge propagation. mrgGuard :: (Alternative m, TryMerge m) => Bool -> m () -mrgGuard True = mrgPure () -mrgGuard False = mrgEmpty +mrgGuard = Unified.mrgGuard {-# INLINE mrgGuard #-} --- | 'guard' with 'MergingStrategy' knowledge propagation and symbolic --- conditions. -symGuard :: (UnionMergeable1 m, TryMerge m, Alternative m) => SymBool -> m () -symGuard b = mrgIf b (mrgPure ()) mrgEmpty +-- | 'Control.Monad.guard' with 'MergingStrategy' knowledge propagation and +-- symbolic conditions. +symGuard :: (SymBranching m, TryMerge m, Alternative m) => SymBool -> m () +symGuard = Unified.symGuard {-# INLINE symGuard #-} --- | 'when' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.when' with 'MergingStrategy' knowledge propagation. mrgWhen :: (Applicative m, TryMerge m) => Bool -> m () -> m () -mrgWhen True a = tryMerge a -mrgWhen False _ = mrgPure () +mrgWhen = Unified.mrgWhen {-# INLINE mrgWhen #-} --- | 'when' with 'MergingStrategy' knowledge propagation and symbolic --- conditions. +-- | 'Control.Monad.when' with 'MergingStrategy' knowledge propagation and +-- symbolic conditions. symWhen :: - (Applicative m, TryMerge m, UnionMergeable1 m) => SymBool -> m () -> m () -symWhen b a = mrgIf b a (mrgPure ()) + (Applicative m, TryMerge m, SymBranching m) => SymBool -> m () -> m () +symWhen = Unified.symWhen {-# INLINE symWhen #-} --- | 'unless' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.unless' with 'MergingStrategy' knowledge propagation. mrgUnless :: (Applicative m, TryMerge m) => Bool -> m () -> m () -mrgUnless b = mrgWhen (not b) +mrgUnless = Unified.mrgUnless {-# INLINE mrgUnless #-} --- | 'unless' with 'MergingStrategy' knowledge propagation and symbolic --- conditions. +-- | 'Control.Monad.unless' with 'MergingStrategy' knowledge propagation and +-- symbolic conditions. symUnless :: - (Applicative m, TryMerge m, UnionMergeable1 m) => SymBool -> m () -> m () -symUnless b = symWhen (symNot b) + (Applicative m, TryMerge m, SymBranching m) => SymBool -> m () -> m () +symUnless = Unified.symUnless {-# INLINE symUnless #-} --- | 'liftM' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.liftM' with 'MergingStrategy' knowledge propagation. mrgLiftM :: (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> b) -> m a -> m b -mrgLiftM f a = f .<$> a +mrgLiftM = Unified.mrgLiftM {-# INLINE mrgLiftM #-} --- | 'liftM2' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.liftM2' with 'MergingStrategy' knowledge propagation. mrgLiftM2 :: (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) => (a -> b -> c) -> m a -> m b -> m c -mrgLiftM2 f a b = f .<$> a .<*> b +mrgLiftM2 = Unified.mrgLiftM2 {-# INLINE mrgLiftM2 #-} --- | 'liftM3' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.liftM3' with 'MergingStrategy' knowledge propagation. mrgLiftM3 :: (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c, Mergeable d) => (a -> b -> c -> d) -> @@ -440,10 +400,10 @@ m b -> m c -> m d -mrgLiftM3 f a b c = f .<$> a .<*> b .<*> c +mrgLiftM3 = Unified.mrgLiftM3 {-# INLINE mrgLiftM3 #-} --- | 'liftM4' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.liftM4' with 'MergingStrategy' knowledge propagation. mrgLiftM4 :: ( MonadTryMerge m, Mergeable a, @@ -458,10 +418,10 @@ m c -> m d -> m e -mrgLiftM4 f a b c d = f .<$> a .<*> b .<*> c .<*> d +mrgLiftM4 = Unified.mrgLiftM4 {-# INLINE mrgLiftM4 #-} --- | 'liftM5' with 'MergingStrategy' knowledge propagation. +-- | 'Control.Monad.liftM5' with 'MergingStrategy' knowledge propagation. mrgLiftM5 :: ( MonadTryMerge m, Mergeable a, @@ -478,20 +438,20 @@ m d -> m e -> m f -mrgLiftM5 f a b c d e = f .<$> a .<*> b .<*> c .<*> d .<*> e +mrgLiftM5 = Unified.mrgLiftM5 {-# INLINE mrgLiftM5 #-} -- | '<*>' with 'MergingStrategy' knowledge propagation. mrgAp :: (MonadTryMerge m, Mergeable a, Mergeable b) => m (a -> b) -> m a -> m b -mrgAp = (.<*>) +mrgAp = Unified.mrgAp {-# INLINE mrgAp #-} infixl 4 .<$!> --- | '<$!>' with 'MergingStrategy' knowledge propagation. Merging is always --- strict so we can directly use '.<$>'. +-- | 'Control.Monad.<$!>' with 'MergingStrategy' knowledge propagation. Merging +-- is always strict so we can directly use 'Grisette.Lib.Data.Functor..<$>'. (.<$!>) :: (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> b) -> m a -> m b -f .<$!> a = f .<$> a +(.<$!>) = (Unified..<$!>) {-# INLINE (.<$!>) #-} diff --git a/src/Grisette/Lib/Control/Monad/Except.hs b/src/Grisette/Lib/Control/Monad/Except.hs --- a/src/Grisette/Lib/Control/Monad/Except.hs +++ b/src/Grisette/Lib/Control/Monad/Except.hs @@ -28,14 +28,14 @@ import Grisette.Lib.Control.Monad.Trans.Except (mrgRunExceptT) import Grisette.Lib.Data.Functor (mrgFmap) --- | 'Control.Monad.Except.throwError' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Except.throwError' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgThrowError :: (MonadError e m, TryMerge m, Mergeable a) => e -> m a mrgThrowError = tryMerge . throwError {-# INLINE mrgThrowError #-} --- | 'Control.Monad.Except.catchError' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Except.catchError' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgCatchError :: (MonadError e m, TryMerge m, Mergeable a) => m a -> @@ -44,15 +44,15 @@ mrgCatchError v handler = tryMerge $ v `catchError` (tryMerge . handler) {-# INLINE mrgCatchError #-} --- | 'Control.Monad.Except.liftEither' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Except.liftEither' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgLiftEither :: (MonadError e m, TryMerge m, Mergeable a, Mergeable e) => Either e a -> m a mrgLiftEither = either mrgThrowError mrgReturn {-# INLINE mrgLiftEither #-} --- | 'Control.Monad.Except.tryError' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Except.tryError' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgTryError :: (MonadError e m, TryMerge m, Mergeable a, Mergeable e) => m a -> @@ -60,8 +60,8 @@ mrgTryError action = (mrgFmap Right action) `mrgCatchError` (mrgReturn . Left) {-# INLINE mrgTryError #-} --- | 'Control.Monad.Except.withError' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Except.withError' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgWithError :: (MonadError e m, TryMerge m, Mergeable a, Mergeable e) => (e -> e) -> @@ -71,8 +71,8 @@ tryMerge $ mrgTryError action >>= either (mrgThrowError . f) mrgReturn {-# INLINE mrgWithError #-} --- | 'Control.Monad.Except.handleError' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Except.handleError' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgHandleError :: (MonadError e m, TryMerge m, Mergeable a, Mergeable e) => (e -> m a) -> @@ -81,8 +81,8 @@ mrgHandleError = flip mrgCatchError {-# INLINE mrgHandleError #-} --- | 'Control.Monad.Except.mapError' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Except.mapError' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgMapError :: ( MonadError e m, TryMerge m, @@ -99,8 +99,8 @@ mrgMapError f action = tryMerge (f (mrgTryError action)) >>= mrgLiftEither {-# INLINE mrgMapError #-} --- | 'Control.Monad.Except.modifyError' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Except.modifyError' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgModifyError :: ( MonadError e' m, TryMerge m, diff --git a/src/Grisette/Lib/Control/Monad/State/Class.hs b/src/Grisette/Lib/Control/Monad/State/Class.hs --- a/src/Grisette/Lib/Control/Monad/State/Class.hs +++ b/src/Grisette/Lib/Control/Monad/State/Class.hs @@ -24,20 +24,20 @@ import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) import Grisette.Lib.Control.Monad (mrgReturn) --- | 'Control.Monad.State.Class.get' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.State.Class.get' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgGet :: (MonadState s m, TryMerge m, Mergeable s) => m s mrgGet = tryMerge get {-# INLINE mrgGet #-} --- | 'Control.Monad.State.Class.put' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.State.Class.put' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgPut :: (MonadState s m, TryMerge m) => s -> m () mrgPut = tryMerge . put {-# INLINE mrgPut #-} --- | 'Control.Monad.State.Class.state' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.State.Class.state' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgState :: (MonadState s m, TryMerge m, Mergeable s, Mergeable a) => (s -> (a, s)) -> @@ -48,22 +48,22 @@ mrgPut s' mrgReturn a --- | 'Control.Monad.State.Class.modify' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.State.Class.modify' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgModify :: (MonadState s m, TryMerge m, Mergeable s) => (s -> s) -> m () mrgModify f = mrgState (\s -> ((), f s)) {-# INLINE mrgModify #-} --- | 'Control.Monad.State.Class.modify'' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.State.Class.modify'' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgModify' :: (MonadState s m, TryMerge m, Mergeable s) => (s -> s) -> m () mrgModify' f = do s' <- mrgGet mrgPut $! f s' {-# INLINE mrgModify' #-} --- | 'Control.Monad.State.Class.gets' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.State.Class.gets' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgGets :: (MonadState s m, TryMerge m, Mergeable s, Mergeable a) => (s -> a) -> diff --git a/src/Grisette/Lib/Control/Monad/Trans/Class.hs b/src/Grisette/Lib/Control/Monad/Trans/Class.hs --- a/src/Grisette/Lib/Control/Monad/Trans/Class.hs +++ b/src/Grisette/Lib/Control/Monad/Trans/Class.hs @@ -20,7 +20,7 @@ import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) --- | 'lift' with 'MergingStrategy' knowledge propagation. +-- | 'lift' with 'Grisette.Core.MergingStrategy' knowledge propagation. mrgLift :: forall t m a. (TryMerge (t m), MonadTrans t, Monad m, Mergeable a) => diff --git a/src/Grisette/Lib/Control/Monad/Trans/Cont.hs b/src/Grisette/Lib/Control/Monad/Trans/Cont.hs --- a/src/Grisette/Lib/Control/Monad/Trans/Cont.hs +++ b/src/Grisette/Lib/Control/Monad/Trans/Cont.hs @@ -25,17 +25,20 @@ ) import Grisette.Lib.Control.Monad (mrgReturn) --- | 'Control.Monad.Cont.runContT' with 'MergingStrategy' knowledge propagation +-- | 'Control.Monad.Cont.runContT' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgRunContT :: (TryMerge m, Mergeable r) => ContT r m a -> (a -> m r) -> m r mrgRunContT c = tryMerge . runContT c {-# INLINE mrgRunContT #-} --- | 'Control.Monad.Cont.evalContT' with 'MergingStrategy' knowledge propagation +-- | 'Control.Monad.Cont.evalContT' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgEvalContT :: (TryMerge m, Mergeable r, Monad m) => ContT r m r -> m r mrgEvalContT c = runContT c mrgReturn {-# INLINE mrgEvalContT #-} --- | 'Control.Monad.Cont.resetT' with 'MergingStrategy' knowledge propagation +-- | 'Control.Monad.Cont.resetT' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgResetT :: (TryMerge m, Mergeable r, Monad m) => ContT r m r -> diff --git a/src/Grisette/Lib/Control/Monad/Trans/Except.hs b/src/Grisette/Lib/Control/Monad/Trans/Except.hs --- a/src/Grisette/Lib/Control/Monad/Trans/Except.hs +++ b/src/Grisette/Lib/Control/Monad/Trans/Except.hs @@ -28,22 +28,22 @@ import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) import Grisette.Internal.Core.Data.Class.TryMerge (MonadTryMerge, tryMerge) --- | 'Control.Monad.Trans.Except.except' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.Except.except' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgExcept :: (MonadTryMerge m, Mergeable e, Mergeable a) => Either e a -> ExceptT e m a mrgExcept = tryMerge . except {-# INLINE mrgExcept #-} --- | 'Control.Monad.Trans.Except.runExceptT' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.Except.runExceptT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgRunExceptT :: (MonadTryMerge m, Mergeable e, Mergeable a) => ExceptT e m a -> m (Either e a) mrgRunExceptT = tryMerge . runExceptT {-# INLINE mrgRunExceptT #-} --- | 'Control.Monad.Trans.Except.withExceptT' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.Except.withExceptT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgWithExceptT :: (MonadTryMerge m, Mergeable a, Mergeable e, Mergeable e') => (e -> e') -> @@ -52,14 +52,14 @@ mrgWithExceptT f e = tryMerge $ withExceptT f (tryMerge e) {-# INLINE mrgWithExceptT #-} --- | 'Control.Monad.Trans.Except.throwE' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.Except.throwE' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgThrowE :: (MonadTryMerge m, Mergeable e, Mergeable a) => e -> ExceptT e m a mrgThrowE = tryMerge . throwE {-# INLINE mrgThrowE #-} --- | 'Control.Monad.Trans.Except.catchE' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.Except.catchE' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgCatchE :: (MonadTryMerge m, Mergeable e, Mergeable a) => ExceptT e m a -> diff --git a/src/Grisette/Lib/Control/Monad/Trans/State/Lazy.hs b/src/Grisette/Lib/Control/Monad/Trans/State/Lazy.hs --- a/src/Grisette/Lib/Control/Monad/Trans/State/Lazy.hs +++ b/src/Grisette/Lib/Control/Monad/Trans/State/Lazy.hs @@ -32,8 +32,8 @@ import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) import Grisette.Lib.Control.Monad (mrgReturn) --- | 'Control.Monad.Trans.State.Lazy.state' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Lazy.state' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgState :: (Monad m, TryMerge m, Mergeable s, Mergeable a) => (s -> (a, s)) -> @@ -41,8 +41,8 @@ mrgState f = StateT (mrgReturn . f) {-# INLINE mrgState #-} --- | 'Control.Monad.Trans.State.Lazy.runStateT' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Lazy.runStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgRunStateT :: (Monad m, TryMerge m, Mergeable s, Mergeable a) => StateT s m a -> @@ -51,8 +51,8 @@ mrgRunStateT m s = tryMerge $ runStateT m s {-# INLINE mrgRunStateT #-} --- | 'Control.Monad.Trans.State.Lazy.evalStateT' with 'MergingStrategy' --- knowledge propagation. +-- | 'Control.Monad.Trans.State.Lazy.evalStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgEvalStateT :: (Monad m, TryMerge m, Mergeable a) => StateT s m a -> @@ -63,8 +63,8 @@ return a {-# INLINE mrgEvalStateT #-} --- | 'Control.Monad.Trans.State.Lazy.execStateT' with 'MergingStrategy' --- knowledge propagation. +-- | 'Control.Monad.Trans.State.Lazy.execStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgExecStateT :: (Monad m, TryMerge m, Mergeable s) => StateT s m a -> @@ -75,8 +75,8 @@ return s' {-# INLINE mrgExecStateT #-} --- | 'Control.Monad.Trans.State.Lazy.mapStateT' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Lazy.mapStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgMapStateT :: (TryMerge n, Mergeable b, Mergeable s) => (m (a, s) -> n (b, s)) -> @@ -85,8 +85,8 @@ mrgMapStateT f m = StateT $ tryMerge . f . runStateT m {-# INLINE mrgMapStateT #-} --- | 'Control.Monad.Trans.State.Lazy.withStateT' with 'MergingStrategy' --- knowledge propagation. +-- | 'Control.Monad.Trans.State.Lazy.withStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgWithStateT :: (TryMerge m, Mergeable s, Mergeable a) => (s -> s) -> @@ -95,34 +95,34 @@ mrgWithStateT f m = StateT $ tryMerge . runStateT m . f {-# INLINE mrgWithStateT #-} --- | 'Control.Monad.Trans.State.Lazy.get' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Lazy.get' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgGet :: (Monad m, TryMerge m, Mergeable s) => StateT s m s mrgGet = mrgState (\s -> (s, s)) {-# INLINE mrgGet #-} --- | 'Control.Monad.Trans.State.Lazy.put' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Lazy.put' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgPut :: (Monad m, TryMerge m, Mergeable s) => s -> StateT s m () mrgPut s = mrgState (const ((), s)) {-# INLINE mrgPut #-} --- | 'Control.Monad.Trans.State.Lazy.modify' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Lazy.modify' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgModify :: (Monad m, TryMerge m, Mergeable s) => (s -> s) -> StateT s m () mrgModify f = mrgState (\s -> ((), f s)) {-# INLINE mrgModify #-} --- | 'Control.Monad.Trans.State.Lazy.modify'' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Lazy.modify'' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgModify' :: (Monad m, TryMerge m, Mergeable s) => (s -> s) -> StateT s m () mrgModify' f = do s <- mrgGet mrgPut $! f s {-# INLINE mrgModify' #-} --- | 'Control.Monad.Trans.State.Lazy.gets' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Lazy.gets' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgGets :: (Monad m, TryMerge m, Mergeable s, Mergeable a) => (s -> a) -> diff --git a/src/Grisette/Lib/Control/Monad/Trans/State/Strict.hs b/src/Grisette/Lib/Control/Monad/Trans/State/Strict.hs --- a/src/Grisette/Lib/Control/Monad/Trans/State/Strict.hs +++ b/src/Grisette/Lib/Control/Monad/Trans/State/Strict.hs @@ -32,8 +32,8 @@ import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) import Grisette.Lib.Control.Monad (mrgReturn) --- | 'Control.Monad.Trans.State.Strict.state' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Strict.state' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgState :: (Monad m, TryMerge m, Mergeable s, Mergeable a) => (s -> (a, s)) -> @@ -41,8 +41,8 @@ mrgState f = StateT (mrgReturn . f) {-# INLINE mrgState #-} --- | 'Control.Monad.Trans.State.Strict.runStateT' with 'MergingStrategy' --- knowledge propagation. +-- | 'Control.Monad.Trans.State.Strict.runStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgRunStateT :: (Monad m, TryMerge m, Mergeable s, Mergeable a) => StateT s m a -> @@ -51,8 +51,8 @@ mrgRunStateT m s = tryMerge $ runStateT m s {-# INLINE mrgRunStateT #-} --- | 'Control.Monad.Trans.State.Strict.evalStateT' with 'MergingStrategy' --- knowledge propagation. +-- | 'Control.Monad.Trans.State.Strict.evalStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgEvalStateT :: (Monad m, TryMerge m, Mergeable a) => StateT s m a -> @@ -63,8 +63,8 @@ return a {-# INLINE mrgEvalStateT #-} --- | 'Control.Monad.Trans.State.Strict.execStateT' with 'MergingStrategy' --- knowledge propagation. +-- | 'Control.Monad.Trans.State.Strict.execStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgExecStateT :: (Monad m, TryMerge m, Mergeable s) => StateT s m a -> @@ -75,8 +75,8 @@ return s' {-# INLINE mrgExecStateT #-} --- | 'Control.Monad.Trans.State.Strict.mapStateT' with 'MergingStrategy' --- knowledge propagation. +-- | 'Control.Monad.Trans.State.Strict.mapStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgMapStateT :: (TryMerge n, Mergeable b, Mergeable s) => (m (a, s) -> n (b, s)) -> @@ -85,8 +85,8 @@ mrgMapStateT f m = StateT $ tryMerge . f . runStateT m {-# INLINE mrgMapStateT #-} --- | 'Control.Monad.Trans.State.Strict.withStateT' with 'MergingStrategy' --- knowledge propagation. +-- | 'Control.Monad.Trans.State.Strict.withStateT' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgWithStateT :: (TryMerge m, Mergeable s, Mergeable a) => (s -> s) -> @@ -95,34 +95,34 @@ mrgWithStateT f m = StateT $ tryMerge . runStateT m . f {-# INLINE mrgWithStateT #-} --- | 'Control.Monad.Trans.State.Strict.get' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Strict.get' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgGet :: (Monad m, TryMerge m, Mergeable s) => StateT s m s mrgGet = mrgState (\s -> (s, s)) {-# INLINE mrgGet #-} --- | 'Control.Monad.Trans.State.Strict.put' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Strict.put' with 'Grisette.Core.MergingStrategy' +-- knowledge propagation. mrgPut :: (Monad m, TryMerge m, Mergeable s) => s -> StateT s m () mrgPut s = mrgState (const ((), s)) {-# INLINE mrgPut #-} --- | 'Control.Monad.Trans.State.Strict.modify' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Strict.modify' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgModify :: (Monad m, TryMerge m, Mergeable s) => (s -> s) -> StateT s m () mrgModify f = mrgState (\s -> ((), f s)) {-# INLINE mrgModify #-} --- | 'Control.Monad.Trans.State.Strict.modify'' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Strict.modify'' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgModify' :: (Monad m, TryMerge m, Mergeable s) => (s -> s) -> StateT s m () mrgModify' f = do s <- mrgGet mrgPut $! f s {-# INLINE mrgModify' #-} --- | 'Control.Monad.Trans.State.Strict.gets' with 'MergingStrategy' knowledge --- propagation. +-- | 'Control.Monad.Trans.State.Strict.gets' with +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgGets :: (Monad m, TryMerge m, Mergeable s, Mergeable a) => (s -> a) -> diff --git a/src/Grisette/Lib/Data/Bool.hs b/src/Grisette/Lib/Data/Bool.hs --- a/src/Grisette/Lib/Data/Bool.hs +++ b/src/Grisette/Lib/Data/Bool.hs @@ -3,10 +3,18 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Grisette.Lib.Data.Bool +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Lib.Data.Bool (mrgTrue, mrgFalse) where import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) -import Grisette.Internal.Core.TH.MergeConstructor +import Grisette.Internal.TH.MergeConstructor ( mkMergeConstructor, ) diff --git a/src/Grisette/Lib/Data/Either.hs b/src/Grisette/Lib/Data/Either.hs --- a/src/Grisette/Lib/Data/Either.hs +++ b/src/Grisette/Lib/Data/Either.hs @@ -3,10 +3,18 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Grisette.Lib.Data.Either +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Lib.Data.Either (mrgLeft, mrgRight) where import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) -import Grisette.Internal.Core.TH.MergeConstructor +import Grisette.Internal.TH.MergeConstructor ( mkMergeConstructor, ) diff --git a/src/Grisette/Lib/Data/Foldable.hs b/src/Grisette/Lib/Data/Foldable.hs --- a/src/Grisette/Lib/Data/Foldable.hs +++ b/src/Grisette/Lib/Data/Foldable.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Grisette.Lib.Control.Foldable @@ -52,258 +54,201 @@ where import Control.Monad (MonadPlus) -import Data.Foldable (Foldable (foldl')) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, liftUnionM) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Union (Union) import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) -import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.PlainUnion (symIteMerge) -import Grisette.Internal.Core.Data.Class.SEq (SEq ((.==))) -import Grisette.Internal.Core.Data.Class.SOrd (SOrd, mrgMax, mrgMin) -import Grisette.Internal.Core.Data.Class.SimpleMergeable (mrgIf) -import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd) import Grisette.Internal.Core.Data.Class.TryMerge ( MonadTryMerge, TryMerge, - tryMerge, ) import Grisette.Internal.SymPrim.SymBool (SymBool) -import Grisette.Lib.Control.Applicative (mrgAsum, mrgPure, (.*>)) -import {-# SOURCE #-} Grisette.Lib.Control.Monad - ( mrgMplus, - mrgMzero, - mrgReturn, - (.>>), - ) -import Grisette.Lib.Data.Functor (mrgFmap, mrgVoid) +import Grisette.Lib.Control.Applicative (mrgAsum) +import Grisette.Unified (EvalModeTag (Sym)) +import qualified Grisette.Unified.Lib.Data.Foldable as Unified -- | 'Data.Foldable.elem' with symbolic equality. -symElem :: (Foldable t, SEq a) => a -> t a -> SymBool -symElem x = symAny ((.== x)) +symElem :: (Foldable t, SymEq a) => a -> t a -> SymBool +symElem = Unified.symElem {-# INLINE symElem #-} --- | 'Data.Foldable.maximum' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.maximum' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgMaximum :: forall a t m. - (Foldable t, MonadUnion m, Mergeable a, SOrd a) => + (Foldable t, MonadUnion m, Mergeable a, SymOrd a) => t a -> m a -mrgMaximum l = do - r <- mrgFoldlM symMax' (Nothing :: Maybe a) l - case r of - Nothing -> errorWithoutStackTrace "mrgMaximum: empty structure" - Just x -> mrgReturn x - where - symMax' :: Maybe a -> a -> m (Maybe a) - symMax' mx y = - case mx of - Nothing -> mrgReturn $ Just y - Just x -> mrgFmap Just $ mrgMax x y +mrgMaximum = Unified.mrgMaximum @'Sym +{-# INLINE mrgMaximum #-} -- | 'Data.Foldable.maximum' with result merged with 'ITEOp'. symMaximum :: forall a t. - (Foldable t, Mergeable a, SOrd a, ITEOp a) => + (Foldable t, Mergeable a, SymOrd a, ITEOp a) => t a -> a -symMaximum l = symIteMerge (mrgMaximum l :: UnionM a) +symMaximum = Unified.symMaximum @'Sym {-# INLINE symMaximum #-} --- | 'Data.Foldable.minimum' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.minimum' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgMinimum :: forall a t m. - (Foldable t, MonadUnion m, Mergeable a, SOrd a) => + (Foldable t, MonadUnion m, Mergeable a, SymOrd a) => t a -> m a -mrgMinimum l = do - r <- mrgFoldlM symMin' (Nothing :: Maybe a) l - case r of - Nothing -> errorWithoutStackTrace "mrgMinimum: empty structure" - Just x -> mrgReturn x - where - symMin' :: Maybe a -> a -> m (Maybe a) - symMin' mx y = - case mx of - Nothing -> mrgReturn $ Just y - Just x -> mrgFmap Just $ mrgMin x y +mrgMinimum = Unified.mrgMinimum @'Sym +{-# INLINE mrgMinimum #-} -- | 'Data.Foldable.minimum' with result merged with 'ITEOp'. symMinimum :: forall a t. - (Foldable t, Mergeable a, SOrd a, ITEOp a) => + (Foldable t, Mergeable a, SymOrd a, ITEOp a) => t a -> a -symMinimum l = symIteMerge (mrgMinimum l :: UnionM a) +symMinimum = Unified.symMinimum @'Sym {-# INLINE symMinimum #-} --- | 'Data.Foldable.foldrM' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.foldrM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgFoldrM :: (MonadTryMerge m, Mergeable b, Foldable t) => (a -> b -> m b) -> b -> t a -> m b -mrgFoldrM f z0 xs = foldl c mrgPure xs z0 - where - c k x z = tryMerge (f x z) >>= k +mrgFoldrM = Unified.mrgFoldrM {-# INLINE mrgFoldrM #-} --- | 'Data.Foldable.foldlM' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.foldlM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgFoldlM :: (MonadTryMerge m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b -mrgFoldlM f z0 xs = foldr c mrgPure xs z0 - where - c x k z = tryMerge (f z x) >>= k +mrgFoldlM = Unified.mrgFoldlM {-# INLINE mrgFoldlM #-} --- | 'Data.Foldable.traverse_' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.traverse_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgTraverse_ :: (Applicative m, TryMerge m, Foldable t) => (a -> m b) -> t a -> m () -mrgTraverse_ f = foldr c (mrgPure ()) - where - c x k = mrgVoid (f x) .*> k +mrgTraverse_ = Unified.mrgTraverse_ {-# INLINE mrgTraverse_ #-} --- | 'Data.Foldable.for_' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.for_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgFor_ :: (Applicative m, TryMerge m, Foldable t) => t a -> (a -> m b) -> m () -mrgFor_ = flip mrgTraverse_ +mrgFor_ = Unified.mrgFor_ {-# INLINE mrgFor_ #-} --- | 'Data.Foldable.sequence_' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.sequence_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgSequenceA_ :: (Foldable t, TryMerge m, Applicative m) => t (m a) -> m () -mrgSequenceA_ = foldr c (mrgPure ()) - where - c m k = mrgVoid m .*> k +mrgSequenceA_ = Unified.mrgSequenceA_ {-# INLINE mrgSequenceA_ #-} --- | 'Data.Foldable.mapM_' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.mapM_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgMapM_ :: (MonadTryMerge m, Foldable t) => (a -> m b) -> t a -> m () -mrgMapM_ = mrgTraverse_ +mrgMapM_ = Unified.mrgMapM_ {-# INLINE mrgMapM_ #-} --- | 'Data.Foldable.forM_' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.forM_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgForM_ :: (MonadTryMerge m, Foldable t) => t a -> (a -> m b) -> m () -mrgForM_ = flip mrgMapM_ +mrgForM_ = Unified.mrgForM_ {-# INLINE mrgForM_ #-} --- | 'Data.Foldable.sequence_' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.sequence_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgSequence_ :: (Foldable t, MonadTryMerge m) => t (m a) -> m () -mrgSequence_ = foldr c (mrgPure ()) - where - c m k = mrgVoid m .>> k +mrgSequence_ = Unified.mrgSequence_ {-# INLINE mrgSequence_ #-} --- | 'Data.Foldable.msum' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.msum' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgMsum :: (MonadTryMerge m, Mergeable a, MonadPlus m, Foldable t) => t (m a) -> m a -mrgMsum = foldr mrgMplus mrgMzero +mrgMsum = Unified.mrgMsum {-# INLINE mrgMsum #-} -- | 'Data.Foldable.and' on symbolic boolean. symAnd :: (Foldable t) => t SymBool -> SymBool -symAnd = foldl' (.&&) (con True) +symAnd = Unified.symAnd -- | 'Data.Foldable.or' on symbolic boolean. symOr :: (Foldable t) => t SymBool -> SymBool -symOr = foldl' (.||) (con False) +symOr = Unified.symOr -- | 'Data.Foldable.any' on symbolic boolean. symAny :: (Foldable t) => (a -> SymBool) -> t a -> SymBool -symAny f = foldl' (\acc v -> acc .|| f v) (con False) +symAny = Unified.symAny -- | 'Data.Foldable.all' on symbolic boolean. symAll :: (Foldable t) => (a -> SymBool) -> t a -> SymBool -symAll f = foldl' (\acc v -> acc .&& f v) (con True) +symAll = Unified.symAll --- | 'Data.Foldable.maximumBy' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.maximumBy' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgMaximumBy :: forall t a m. (Foldable t, Mergeable a, MonadUnion m) => - (a -> a -> UnionM Ordering) -> + (a -> a -> Union Ordering) -> t a -> m a -mrgMaximumBy cmp l = do - r <- mrgFoldlM symMax' (Nothing :: Maybe a) l - case r of - Nothing -> errorWithoutStackTrace "mrgMaximumBy: empty structure" - Just x -> mrgReturn x - where - symMax' :: Maybe a -> a -> m (Maybe a) - symMax' mx y = - case mx of - Nothing -> mrgReturn $ Just y - Just x -> do - cmpRes <- liftUnionM $ cmp x y - case cmpRes of - GT -> mrgReturn $ Just x - _ -> mrgReturn $ Just y +mrgMaximumBy = Unified.mrgMaximumBy +{-# INLINE mrgMaximumBy #-} -- | 'Data.Foldable.maximumBy' with result merged with 'ITEOp'. symMaximumBy :: forall t a. (Foldable t, Mergeable a, ITEOp a) => - (a -> a -> UnionM Ordering) -> + (a -> a -> Union Ordering) -> t a -> a -symMaximumBy cmp l = symIteMerge (mrgMaximumBy cmp l :: UnionM a) +symMaximumBy = Unified.symMaximumBy {-# INLINE symMaximumBy #-} --- | 'Data.Foldable.minimumBy' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Foldable.minimumBy' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgMinimumBy :: forall t a m. (Foldable t, Mergeable a, MonadUnion m) => - (a -> a -> UnionM Ordering) -> + (a -> a -> Union Ordering) -> t a -> m a -mrgMinimumBy cmp l = do - r <- mrgFoldlM symMin' (Nothing :: Maybe a) l - case r of - Nothing -> errorWithoutStackTrace "mrgMinimumBy: empty structure" - Just x -> mrgReturn x - where - symMin' :: Maybe a -> a -> m (Maybe a) - symMin' mx y = - case mx of - Nothing -> mrgReturn $ Just y - Just x -> do - cmpRes <- liftUnionM $ cmp x y - case cmpRes of - GT -> mrgReturn $ Just y - _ -> mrgReturn $ Just x +mrgMinimumBy = Unified.mrgMinimumBy +{-# INLINE mrgMinimumBy #-} -- | 'Data.Foldable.minimumBy' with result merged with 'ITEOp'. symMinimumBy :: forall t a. (Foldable t, Mergeable a, ITEOp a) => - (a -> a -> UnionM Ordering) -> + (a -> a -> Union Ordering) -> t a -> a -symMinimumBy cmp l = symIteMerge (mrgMinimumBy cmp l :: UnionM a) +symMinimumBy = Unified.symMinimumBy {-# INLINE symMinimumBy #-} -- | 'Data.Foldable.elem' with symbolic equality. -symNotElem :: (Foldable t, SEq a) => a -> t a -> SymBool -symNotElem x = symNot . symElem x +symNotElem :: (Foldable t, SymEq a) => a -> t a -> SymBool +symNotElem = Unified.symNotElem {-# INLINE symNotElem #-} --- | 'Data.Foldable.elem' with symbolic equality and 'MergingStrategy' knowledge --- propagation. +-- | 'Data.Foldable.elem' with symbolic equality and +-- 'Grisette.Core.MergingStrategy' knowledge propagation. mrgFind :: (Foldable t, MonadUnion m, Mergeable a) => (a -> SymBool) -> t a -> m (Maybe a) -mrgFind f = mrgFoldlM fst (Nothing :: Maybe a) - where - fst acc v = do - case acc of - Just _ -> mrgPure acc - Nothing -> do - mrgIf (f v) (mrgPure $ Just v) (mrgPure Nothing) +mrgFind = Unified.mrgFind +{-# INLINE mrgFind #-} diff --git a/src/Grisette/Lib/Data/Functor.hs b/src/Grisette/Lib/Data/Functor.hs --- a/src/Grisette/Lib/Data/Functor.hs +++ b/src/Grisette/Lib/Data/Functor.hs @@ -17,63 +17,64 @@ ) where -import Control.Monad (void) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import qualified Grisette.Unified.Lib.Data.Functor as Unified --- | 'fmap' with 'MergingStrategy' knowledge propagation. +-- | 'fmap' with 'Grisette.Core.MergingStrategy' knowledge propagation. mrgFmap :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => (a -> b) -> f a -> f b -mrgFmap f a = tryMerge $ fmap f (tryMerge a) +mrgFmap = Unified.mrgFmap {-# INLINE mrgFmap #-} infixl 4 .<$> --- | '<$>' with 'MergingStrategy' knowledge propagation. +-- | '<$>' with 'Grisette.Core.MergingStrategy' knowledge propagation. (.<$>) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => (a -> b) -> f a -> f b -(.<$>) = mrgFmap +(.<$>) = (Unified..<$>) {-# INLINE (.<$>) #-} infixl 4 .<$ --- | '<$' with 'MergingStrategy' knowledge propagation. +-- | '<$' with 'Grisette.Core.MergingStrategy' knowledge propagation. (.<$) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => b -> f a -> f b -(.<$) v f = tryMerge $ v <$ tryMerge f +(.<$) = (Unified..<$) {-# INLINE (.<$) #-} infixl 4 .$> --- | '$>' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Functor.$>' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. (.$>) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => f a -> b -> f b -(.$>) = flip (.<$) +(.$>) = (Unified..$>) {-# INLINE (.$>) #-} infixl 1 .<&> --- | '<&>' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Functor.<&>' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. (.<&>) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => f a -> (a -> b) -> f b -(.<&>) = flip mrgFmap +(.<&>) = (Unified..<&>) {-# INLINE (.<&>) #-} --- | 'unzip' with 'MergingStrategy' knowledge propagation. +-- | 'unzip' with 'Grisette.Core.MergingStrategy' knowledge propagation. mrgUnzip :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => f (a, b) -> (f a, f b) -mrgUnzip ab = - let mergedAb = tryMerge ab - in (fst .<$> mergedAb, snd .<$> mergedAb) +mrgUnzip = Unified.mrgUnzip {-# INLINE mrgUnzip #-} --- | 'void' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Functor.void' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgVoid :: (TryMerge f, Functor f) => f a -> f () -mrgVoid x = tryMerge $ void x +mrgVoid = Unified.mrgVoid {-# INLINE mrgVoid #-} diff --git a/src/Grisette/Lib/Data/Functor/Sum.hs b/src/Grisette/Lib/Data/Functor/Sum.hs --- a/src/Grisette/Lib/Data/Functor/Sum.hs +++ b/src/Grisette/Lib/Data/Functor/Sum.hs @@ -3,11 +3,19 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Grisette.Lib.Data.Functor.Sum +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Lib.Data.Functor.Sum (mrgInR, mrgInL) where import Data.Functor.Sum (Sum) import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) -import Grisette.Internal.Core.TH.MergeConstructor +import Grisette.Internal.TH.MergeConstructor ( mkMergeConstructor, ) diff --git a/src/Grisette/Lib/Data/List.hs b/src/Grisette/Lib/Data/List.hs --- a/src/Grisette/Lib/Data/List.hs +++ b/src/Grisette/Lib/Data/List.hs @@ -75,7 +75,7 @@ -- ** The "By" operations - -- *** User-supplied equality (replacing an 'SEq' context) + -- *** User-supplied equality (replacing an 'SymEq' context) mrgNubBy, mrgDeleteBy, mrgDeleteFirstsBy, @@ -83,7 +83,7 @@ mrgIntersectBy, mrgGroupBy, - -- *** User-supplied comparison (replacing an 'SOrd' context) + -- *** User-supplied comparison (replacing an 'SymOrd' context) mrgInsertBy, mrgMaximumBy, symMaximumBy, @@ -95,15 +95,15 @@ import Data.Bifunctor (Bifunctor (first, second)) import Data.List (tails) import Data.Maybe (listToMaybe) -import Grisette.Internal.Core.Control.Monad.Union (MonadUnion) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM, liftUnionM) +import Grisette.Internal.Core.Control.Monad.Class.Union (MonadUnion) +import Grisette.Internal.Core.Control.Monad.Union (Union, liftUnion) import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp (symIte)) import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.&&), (.||))) import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) -import Grisette.Internal.Core.Data.Class.SEq (SEq ((./=), (.==))) -import Grisette.Internal.Core.Data.Class.SOrd (SOrd ((.<=), (.>=))) -import Grisette.Internal.Core.Data.Class.SimpleMergeable (UnionMergeable1, mrgIf) +import Grisette.Internal.Core.Data.Class.SimpleMergeable (SymBranching, mrgIf) import Grisette.Internal.Core.Data.Class.Solvable (Solvable (con)) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((./=), (.==))) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd ((.<=), (.>=))) import Grisette.Internal.SymPrim.SymBool (SymBool) import Grisette.Lib.Control.Applicative (mrgPure) import Grisette.Lib.Control.Monad (mrgReturn) @@ -128,7 +128,7 @@ import Grisette.Lib.Data.Functor (mrgFmap) symListOpOnSymInt :: - (Applicative u, UnionMergeable1 u, Mergeable b, Num int, SOrd int) => + (Applicative u, SymBranching u, Mergeable b, Num int, SymOrd int) => Bool -> (Int -> [a] -> b) -> int -> @@ -153,7 +153,7 @@ -- -- Can generate O(n) cases and O(n) sized branch constraints. mrgTake :: - (Applicative u, UnionMergeable1 u, Mergeable a, Num int, SOrd int) => + (Applicative u, SymBranching u, Mergeable a, Num int, SymOrd int) => int -> [a] -> u [a] @@ -164,7 +164,7 @@ -- -- Can generate O(n) cases and O(n) sized branch constraints. mrgDrop :: - (Applicative u, UnionMergeable1 u, Mergeable a, Num int, SOrd int) => + (Applicative u, SymBranching u, Mergeable a, Num int, SymOrd int) => int -> [a] -> u [a] @@ -176,7 +176,7 @@ -- Can generate O(n) cases and O(n) sized branch constraints. mrgSplitAt :: forall a int u. - (MonadUnion u, Mergeable a, Num int, SOrd int) => + (MonadUnion u, Mergeable a, Num int, SymOrd int) => int -> [a] -> u ([a], [a]) @@ -187,7 +187,7 @@ -- -- Can generate O(n) cases and O(n) sized branch constraints. mrgTakeWhile :: - (Applicative u, UnionMergeable1 u, Mergeable a) => + (Applicative u, SymBranching u, Mergeable a) => (a -> SymBool) -> [a] -> u [a] @@ -200,7 +200,7 @@ -- -- Can generate O(n) cases and O(n) sized branch constraints. mrgDropWhile :: - (Applicative u, UnionMergeable1 u, Mergeable a) => + (Applicative u, SymBranching u, Mergeable a) => (a -> SymBool) -> [a] -> u [a] @@ -234,7 +234,7 @@ -- -- Can generate O(n) cases and O(n) sized branch constraints. mrgSpan :: - (Applicative u, UnionMergeable1 u, Mergeable a) => + (Applicative u, SymBranching u, Mergeable a) => (a -> SymBool) -> [a] -> u ([a], [a]) @@ -247,7 +247,7 @@ -- -- Can generate O(n) cases and O(n) sized branch constraints. mrgBreak :: - (Applicative u, UnionMergeable1 u, Mergeable a) => + (Applicative u, SymBranching u, Mergeable a) => (a -> SymBool) -> [a] -> u ([a], [a]) @@ -258,7 +258,7 @@ -- -- Generate O(1) cases and O(len(prefix)) sized branch constraints. mrgStripPrefix :: - (Applicative u, UnionMergeable1 u, Mergeable a, SEq a) => + (Applicative u, SymBranching u, Mergeable a, SymEq a) => [a] -> [a] -> u (Maybe [a]) @@ -273,7 +273,7 @@ -- This function can be very inefficient on large symbolic lists and generate -- O(2^n) cases. Use with caution. mrgGroup :: - (MonadUnion u, Mergeable a, SEq a) => + (MonadUnion u, Mergeable a, SymEq a) => [a] -> u [[a]] mrgGroup = mrgGroupBy (.==) @@ -281,7 +281,7 @@ -- | Symbolic version of 'Data.List.isPrefixOf'. -- -- Generate O(len(prefix)) sized constraints. -symIsPrefixOf :: (SEq a) => [a] -> [a] -> SymBool +symIsPrefixOf :: (SymEq a) => [a] -> [a] -> SymBool symIsPrefixOf [] _ = con True symIsPrefixOf _ [] = con False symIsPrefixOf (x : xs) (y : ys) = @@ -290,19 +290,19 @@ -- | Symbolic version of 'Data.List.isSuffixOf'. -- -- Generate O(len(suffix)) sized constraints. -symIsSuffixOf :: (SEq a) => [a] -> [a] -> SymBool +symIsSuffixOf :: (SymEq a) => [a] -> [a] -> SymBool symIsSuffixOf ns hs = symIsPrefixOf (reverse ns) (reverse hs) -- | Symbolic version of 'Data.List.isInfixOf'. -- -- Generate O(len(haystack) * len(needle)) sized constraints. -symIsInfixOf :: (SEq a) => [a] -> [a] -> SymBool +symIsInfixOf :: (SymEq a) => [a] -> [a] -> SymBool symIsInfixOf needle haystack = symAny (symIsPrefixOf needle) (tails haystack) -- | Symbolic version of 'Data.List.isSubsequenceOf'. -- -- Generate O(len(haystack) * len(needle)) sized constraints. -symIsSubsequenceOf :: (SEq a) => [a] -> [a] -> SymBool +symIsSubsequenceOf :: (SymEq a) => [a] -> [a] -> SymBool symIsSubsequenceOf [] _ = con True symIsSubsequenceOf _ [] = con False symIsSubsequenceOf a@(x : a') (y : b) = @@ -313,7 +313,8 @@ -- -- Can generate O(n) cases and O(n) sized branch constraints. mrgLookup :: - (Applicative u, UnionMergeable1 u, Mergeable b, SEq a) => + forall a b u. + (Applicative u, SymBranching u, Mergeable b, SymEq a) => a -> [(a, b)] -> u (Maybe b) @@ -322,6 +323,7 @@ mrgIf (symAll (key ./=) (fst <$> l)) (mrgPure Nothing) $ mrgLookup' l where + mrgLookup' :: [(a, b)] -> u (Maybe b) mrgLookup' [] = error "mrgLookup: impossible" mrgLookup' [(_, y)] = mrgPure $ Just y mrgLookup' ((x, y) : xys) = @@ -333,7 +335,7 @@ -- This function can be very inefficient on large symbolic lists and generate -- O(2^n) cases. Use with caution. mrgFilter :: - (Applicative u, UnionMergeable1 u, Mergeable a) => + (Applicative u, SymBranching u, Mergeable a) => (a -> SymBool) -> [a] -> u [a] @@ -347,7 +349,8 @@ -- This function can be very inefficient on large symbolic lists and generate -- O(2^n) cases. Use with caution. mrgPartition :: - (Applicative u, UnionMergeable1 u, Mergeable a) => + forall u a. + (Applicative u, SymBranching u, Mergeable a) => (a -> SymBool) -> [a] -> u ([a], [a]) @@ -358,6 +361,7 @@ (mrgFmap (first (x :)) partitioned) (mrgFmap (second (x :)) partitioned) where + partitioned :: u ([a], [a]) partitioned = mrgPartition p xs -- | Symbolic version of 'Data.List.!?', the result would be merged and @@ -365,16 +369,18 @@ -- -- Can generate O(1) cases and O(n) sized branch constraints. (.!?) :: + forall a uf int. ( MonadUnion uf, Mergeable a, Num int, - SEq int + SymEq int ) => [a] -> int -> uf (Maybe a) l .!? p = go l p 0 where + go :: [a] -> int -> int -> uf (Maybe a) go [] _ _ = mrgReturn Nothing go (x : xs) p1 i = mrgIf (p1 .== i) (mrgReturn $ Just x) (go xs p1 $ i + 1) @@ -384,7 +390,7 @@ -- Can generate O(n) cases (or O(1) if int is merged), and O(n^2) sized -- constraints. mrgElemIndex :: - (MonadUnion u, Mergeable int, SEq a, Num int) => + (MonadUnion u, Mergeable int, SymEq a, Num int) => a -> [a] -> u (Maybe int) @@ -395,7 +401,7 @@ -- -- Can generate O(n) cases, and O(n^3) sized constraints. mrgElemIndices :: - (MonadUnion u, Mergeable int, SEq a, Num int) => + (MonadUnion u, Mergeable int, SymEq a, Num int) => a -> [a] -> u [int] @@ -407,7 +413,7 @@ -- Can generate O(n) cases (or O(1) if int is merged), and O(n^2) sized -- constraints, assuming the predicate only generates O(1) constraints. mrgFindIndex :: - (Applicative u, UnionMergeable1 u, Mergeable int, SEq a, Num int) => + (Applicative u, SymBranching u, Mergeable int, SymEq a, Num int) => (a -> SymBool) -> [a] -> u (Maybe int) @@ -419,12 +425,14 @@ -- Can generate O(n) cases, and O(n^3) sized constraints, assuming the predicate -- only generates O(1) constraints. mrgFindIndices :: - (Applicative u, UnionMergeable1 u, Mergeable int, SEq a, Num int) => + forall u a int. + (Applicative u, SymBranching u, Mergeable int, SymEq a, Num int) => (a -> SymBool) -> [a] -> u [int] mrgFindIndices p xs = go $ zip xs $ fromIntegral <$> [0 ..] where + go :: [(a, int)] -> u [int] go [] = mrgPure [] go ((x, y) : xys) = mrgIf (p x) (mrgFmap (y :) $ go xys) (go xys) @@ -433,7 +441,7 @@ -- -- Can generate O(n) cases, and O(n^3) sized constraints. mrgNub :: - (Applicative u, UnionMergeable1 u, Mergeable a, SEq a) => + (Applicative u, SymBranching u, Mergeable a, SymEq a) => [a] -> u [a] mrgNub = mrgNubBy (.==) @@ -443,7 +451,7 @@ -- -- Can generate O(n) cases, and O(n^2) sized constraints. mrgDelete :: - (Applicative u, UnionMergeable1 u, Mergeable a, SEq a) => + (Applicative u, SymBranching u, Mergeable a, SymEq a) => a -> [a] -> u [a] @@ -455,7 +463,7 @@ -- Can generate O(len(lhs)) cases, and O(len(lhs)^2 * len(rhs)) sized -- constraints. (.\\) :: - (MonadUnion u, Mergeable a, SEq a) => + (MonadUnion u, Mergeable a, SymEq a) => [a] -> [a] -> u [a] @@ -469,14 +477,18 @@ -- -- Should be improvable. mrgUnion :: - (MonadUnion u, Mergeable a, SEq a) => + (MonadUnion u, Mergeable a, SymEq a) => [a] -> [a] -> u [a] mrgUnion = mrgUnionBy (.==) +-- | Symbolic version of 'Data.List.intersect', the result would be merged and +-- propagate the mergeable knowledge. +-- +-- Can generate O(len(rhs)) cases, and O(len(lhs) * len(rhs)) constraints. mrgIntersect :: - (MonadUnion u, Mergeable a, SEq a) => + (MonadUnion u, Mergeable a, SymEq a) => [a] -> [a] -> u [a] @@ -488,12 +500,14 @@ -- Can generate O(n) cases, and O(n^3) sized constraints, assuming the predicate -- only generates O(1) constraints. mrgNubBy :: - (Applicative u, UnionMergeable1 u, Mergeable a) => + forall a u. + (Applicative u, SymBranching u, Mergeable a) => (a -> a -> SymBool) -> [a] -> u [a] mrgNubBy eq l = mrgNubBy' l [] where + mrgNubBy' :: [a] -> [a] -> u [a] mrgNubBy' [] _ = mrgPure [] mrgNubBy' (y : ys) xs = mrgIf @@ -509,7 +523,7 @@ -- Can generate O(n) cases, and O(n^2) sized constraints, assuming the predicate -- only generates O(1) constraints. mrgDeleteBy :: - (Applicative u, UnionMergeable1 u, Mergeable a) => + (Applicative u, SymBranching u, Mergeable a) => (a -> a -> SymBool) -> a -> [a] -> @@ -584,7 +598,7 @@ -- -- Can generate 1 case, and O(n^2) sized constraints. mrgInsert :: - (MonadUnion m, Mergeable a, SOrd a) => + (MonadUnion m, Mergeable a, SymOrd a) => a -> [a] -> m [a] @@ -599,13 +613,13 @@ -- function only generates O(1) constraints. mrgInsertBy :: (MonadUnion m, Mergeable a) => - (a -> a -> UnionM Ordering) -> + (a -> a -> Union Ordering) -> a -> [a] -> m [a] mrgInsertBy _ x [] = mrgPure [x] mrgInsertBy cmp x ys@(y : ys') = do - r <- liftUnionM $ cmp x y + r <- liftUnion $ cmp x y case r of GT -> mrgFmap (y :) $ mrgInsertBy cmp x ys' _ -> mrgReturn $ x : ys diff --git a/src/Grisette/Lib/Data/Maybe.hs b/src/Grisette/Lib/Data/Maybe.hs --- a/src/Grisette/Lib/Data/Maybe.hs +++ b/src/Grisette/Lib/Data/Maybe.hs @@ -3,10 +3,18 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Grisette.Lib.Data.Maybe +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Lib.Data.Maybe (mrgNothing, mrgJust) where import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) -import Grisette.Internal.Core.TH.MergeConstructor +import Grisette.Internal.TH.MergeConstructor ( mkMergeConstructor, ) diff --git a/src/Grisette/Lib/Data/Traversable.hs b/src/Grisette/Lib/Data/Traversable.hs --- a/src/Grisette/Lib/Data/Traversable.hs +++ b/src/Grisette/Lib/Data/Traversable.hs @@ -39,7 +39,8 @@ ) import Grisette.Lib.Control.Applicative (mrgPure) --- | 'Data.Traversable.traverse' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Traversable.traverse' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgTraverse :: forall a b t f. ( Mergeable b, @@ -54,7 +55,8 @@ mrgTraverse f = tryMergeWithStrategy rootStrategy1 . traverse (tryMerge . f) {-# INLINE mrgTraverse #-} --- | 'Data.Traversable.sequenceA' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Traversable.sequenceA' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgSequenceA :: forall a t f. ( Mergeable a, @@ -68,7 +70,8 @@ mrgSequenceA = mrgTraverse id {-# INLINE mrgSequenceA #-} --- | 'Data.Traversable.mapM' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Traversable.mapM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgMapM :: forall a b t f. ( Mergeable b, @@ -82,7 +85,8 @@ mrgMapM = mrgTraverse {-# INLINE mrgMapM #-} --- | 'Data.Traversable.sequence' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Traversable.sequence' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgSequence :: forall a t f. ( Mergeable a, @@ -95,7 +99,8 @@ mrgSequence = mrgSequenceA {-# INLINE mrgSequence #-} --- | 'Data.Traversable.for' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Traversable.for' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgFor :: ( Mergeable b, Mergeable1 t, @@ -109,7 +114,8 @@ mrgFor = flip mrgTraverse {-# INLINE mrgFor #-} --- | 'Data.Traversable.forM' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Traversable.forM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgForM :: ( Mergeable b, Mergeable1 t, @@ -122,7 +128,8 @@ mrgForM = flip mrgMapM {-# INLINE mrgForM #-} --- | 'Data.Traversable.mapAccumM' with 'MergingStrategy' knowledge propagation. +-- | 'Data.Traversable.mapAccumM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgMapAccumM :: (MonadTryMerge m, Traversable t, Mergeable s, Mergeable b, Mergeable1 t) => (s -> a -> m (s, b)) -> @@ -141,7 +148,8 @@ return (s, tb) {-# INLINE mrgMapAccumM #-} --- | 'Data.Traversable.forAccumM' and 'MergingStrategy' knowledge propagation. +-- | 'Data.Traversable.forAccumM' and 'Grisette.Core.MergingStrategy' knowledge +-- propagation. mrgForAccumM :: (MonadTryMerge m, Traversable t, Mergeable s, Mergeable b, Mergeable1 t) => s -> diff --git a/src/Grisette/Lib/Data/Tuple.hs b/src/Grisette/Lib/Data/Tuple.hs --- a/src/Grisette/Lib/Data/Tuple.hs +++ b/src/Grisette/Lib/Data/Tuple.hs @@ -4,6 +4,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +-- | +-- Module : Grisette.Lib.Data.Tuple +-- Copyright : (c) Sirui Lu 2021-2023 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only module Grisette.Lib.Data.Tuple ( mrgUnit, mrgTuple2, @@ -17,7 +25,7 @@ where import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) -import Grisette.Internal.Core.TH.MergeConstructor +import Grisette.Internal.TH.MergeConstructor ( mkMergeConstructor', ) diff --git a/src/Grisette/SymPrim.hs b/src/Grisette/SymPrim.hs --- a/src/Grisette/SymPrim.hs +++ b/src/Grisette/SymPrim.hs @@ -12,20 +12,76 @@ -- Stability : Experimental -- Portability : GHC only module Grisette.SymPrim - ( -- * Symbolic type implementation + ( -- | Grisette introduces new primitive types: + -- + -- * @'IntN' n@: signed bit vectors of bit width @n@. + -- * @'WordN' n@: unsigned bit vectors of bit width @n@. + -- * @'FP' eb sb@: IEEE-754 floating point numbers with @eb@ exponent bits + -- and @sb@ significand bits. + -- * @'Bool' t'=->' 'Bool'@: functions represented as a table for the + -- input-output relations. + -- * @'Bool' t'-->' 'Bool'@: functions represented as a formula over some + -- bound variables. + -- + -- We also provide symbolic counterparts for these types, along with the + -- basic types 'Bool' and 'Integer'. These symbolic types can be directly + -- translated to constraints in the SMT solver. + -- + -- * 'SymBool' ('Bool', symbolic Booleans) + -- * 'SymInteger' ('Integer', symbolic unbounded integers) + -- * @'SymIntN' n@ (@'IntN' n@, symbolic signed bit vectors of bit width + -- @n@) + -- * @'SymWordN' n@ (@'WordN' n@, symbolic unsigned bit vectors of bit width + -- @n@) + -- * @'SymFP' eb sb@ (@'FP' eb sb@, symbolic IEEE-754 floating point numbers + -- with @eb@ exponent bits and @sb@ significand bits) + -- * @'SymBool' t'=~>' 'SymBool'@ (@'Bool' t'=->' 'Bool'@, symbolic + -- functions, uninterpreted or represented as a table for the + -- input-output relations). + -- * @'SymBool' t'-~>' 'SymBool'@ (@'Bool' t'-->' 'Bool'@, symbolic + -- functions, uninterpreted or represented as a formula over some + -- bound variables). + -- + -- This module provides an operation to extract all primitive values from a + -- symbolic value, with 'AllSyms'. The module also provides the + -- representation for symbols ('TypedSymbol'), symbol sets ('SymbolSet'), + -- and models ('Model'). They are useful when working with + -- t'Grisette.Core.EvalSym', t'Grisette.Core.ExtractSym', and + -- t'Grisette.Core.SubstSym'. - -- ** Extended types + -- * Extended types + + -- ** Size-tagged bit-vector types IntN, + IntN8, + IntN16, + IntN32, + IntN64, WordN, + WordN8, + WordN16, + WordN32, + WordN64, + + -- ** Runtime-sized bit-vector types SomeBV (..), BitwidthMismatch (..), pattern SomeIntN, type SomeIntN, pattern SomeWordN, type SomeWordN, - type (=->) (..), - type (-->), - (-->), + conBV, + conBVView, + pattern ConBV, + symBV, + ssymBV, + isymBV, + arbitraryBV, + + -- *** Some low-level helpers for writing instances for 'SomeBV' + + -- | The functions here will check the bitwidths of the input bit-vectors + -- and raise 'BitwidthMismatch' if they do not match. unsafeSomeBV, unarySomeBV, unarySomeBVR1, @@ -35,38 +91,82 @@ binSomeBVSafe, binSomeBVSafeR1, binSomeBVSafeR2, - conBV, - conBVView, - pattern ConBV, - symBV, - ssymBV, - isymBV, - arbitraryBV, - -- ** Symbolic types - SupportedPrim, - SymRep (SymType), - ConRep (ConType), - LinkedRep, + -- ** Floating point + ValidFP, + FP, + FP16, + FP32, + FP64, + withValidFPProofs, + FPRoundingMode (..), + allFPRoundingMode, + + -- ** Functions + type (=->) (..), + type (-->), + (-->), + + -- * Symbolic types + + -- ** Symbolic bool and integer types SymBool (..), SymInteger (..), + + -- ** Symbolic bit-vector types SymWordN (..), + SymWordN8, + SymWordN16, + SymWordN32, + SymWordN64, SymIntN (..), + SymIntN8, + SymIntN16, + SymIntN32, + SymIntN64, SomeSymIntN, SomeSymWordN, pattern SomeSymIntN, pattern SomeSymWordN, + + -- ** Symbolic floating point + SymFP (..), + SymFPRoundingMode (..), + SymFP16, + SymFP32, + SymFP64, + + -- ** Symbolic function, possibly uninterpreted type (=~>) (..), type (-~>) (..), - TypedSymbol (..), - symSize, - symsSize, + + -- ** Basic constraints + SupportedPrim, + SymRep (SymType), + ConRep (ConType), + LinkedRep, + + -- * Extract symbolic values + SomeSym (..), AllSyms (..), + AllSyms1 (..), + allSymsS1, + AllSyms2 (..), + allSymsS2, allSymsSize, + symSize, + symsSize, - -- ** Symbolic constant sets and models - SymbolSet (..), - Model (..), + -- ** Generic 'AllSyms' + AllSymsArgs (..), + GAllSyms (..), + genericAllSymsS, + genericLiftAllSymsS, + + -- * Symbolic constant sets and models + TypedSymbol (..), + SymbolSet, + Model, ModelValuePair (..), ModelSymPair (..), ) @@ -74,15 +174,42 @@ import Grisette.Internal.SymPrim.AllSyms ( AllSyms (..), + AllSyms1 (..), + AllSyms2 (..), + AllSymsArgs (..), + GAllSyms (..), + SomeSym (..), + allSymsS1, + allSymsS2, allSymsSize, + genericAllSymsS, + genericLiftAllSymsS, symSize, symsSize, ) import Grisette.Internal.SymPrim.BV ( BitwidthMismatch (..), IntN, + IntN16, + IntN32, + IntN64, + IntN8, WordN, + WordN16, + WordN32, + WordN64, + WordN8, ) +import Grisette.Internal.SymPrim.FP + ( FP, + FP16, + FP32, + FP64, + FPRoundingMode (..), + ValidFP, + allFPRoundingMode, + withValidFPProofs, + ) import Grisette.Internal.SymPrim.GeneralFun (type (-->)) import Grisette.Internal.SymPrim.ModelRep (ModelSymPair (..)) import Grisette.Internal.SymPrim.Prim.Model @@ -126,10 +253,25 @@ ) import Grisette.Internal.SymPrim.SymBV ( SymIntN (..), + SymIntN16, + SymIntN32, + SymIntN64, + SymIntN8, SymWordN (..), + SymWordN16, + SymWordN32, + SymWordN64, + SymWordN8, ) import Grisette.Internal.SymPrim.SymBool ( SymBool (..), + ) +import Grisette.Internal.SymPrim.SymFP + ( SymFP (..), + SymFP16, + SymFP32, + SymFP64, + SymFPRoundingMode (..), ) import Grisette.Internal.SymPrim.SymGeneralFun ((-->), type (-~>) (..)) import Grisette.Internal.SymPrim.SymInteger diff --git a/src/Grisette/TH.hs b/src/Grisette/TH.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/TH.hs @@ -0,0 +1,91 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.TH +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.TH + ( -- * Convenient derivation of all instances relating to Grisette + derive, + deriveAll, + deriveAllExcept, + + -- * Smart constructors that merges in a monad + mkMergeConstructor, + mkMergeConstructor', + + -- * Smart constructors that are polymorphic in evaluation modes + mkUnifiedConstructor, + mkUnifiedConstructor', + + -- * Tools for building more derivation procedures + + -- ** Type parameter handlers + DeriveTypeParamHandler (..), + IsFPBits (..), + NatShouldBePositive (..), + PrimaryConstraint (..), + SomeDeriveTypeParamHandler (..), + + -- ** Instance providers + DeriveInstanceProvider (..), + Strategy (..), + + -- ** For unified interfaces + TypeableMode (..), + PrimaryUnifiedConstraint (..), + UnifiedInstance (..), + + -- ** Other helpers + deriveWithHandlers, + derivePredefined, + derivePredefinedMultipleClasses, + deriveBuiltinExtra, + deriveUnifiedInterfaceExtra, + deriveUnifiedInterface1Extra, + deriveFunctorArgUnifiedInterfaceExtra, + ) +where + +import Grisette.Internal.TH.DeriveBuiltin + ( deriveBuiltinExtra, + ) +import Grisette.Internal.TH.DeriveInstanceProvider + ( DeriveInstanceProvider (..), + Strategy (..), + ) +import Grisette.Internal.TH.DerivePredefined + ( derive, + deriveAll, + deriveAllExcept, + derivePredefined, + derivePredefinedMultipleClasses, + ) +import Grisette.Internal.TH.DeriveTypeParamHandler + ( DeriveTypeParamHandler (..), + IsFPBits (..), + NatShouldBePositive (..), + PrimaryConstraint (..), + SomeDeriveTypeParamHandler (..), + ) +import Grisette.Internal.TH.DeriveUnifiedInterface + ( PrimaryUnifiedConstraint (..), + TypeableMode (..), + UnifiedInstance (..), + deriveFunctorArgUnifiedInterfaceExtra, + deriveUnifiedInterface1Extra, + deriveUnifiedInterfaceExtra, + ) +import Grisette.Internal.TH.DeriveWithHandlers (deriveWithHandlers) +import Grisette.Internal.TH.MergeConstructor + ( mkMergeConstructor, + mkMergeConstructor', + ) +import Grisette.Internal.TH.UnifiedConstructor + ( mkUnifiedConstructor, + mkUnifiedConstructor', + ) diff --git a/src/Grisette/Unified.hs b/src/Grisette/Unified.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified.hs @@ -0,0 +1,209 @@ +{-# OPTIONS_GHC -Wno-missing-import-lists #-} + +-- | +-- Module : Grisette.Unified +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified + ( -- * Evaluation mode + EvalModeTag (..), + IsConMode, + BaseMonad, + + -- * Aggregated constraints + EvalMode, + MonadWithMode, + + -- * Unified operations + + -- ** Unified simple mergeable + UnifiedBranching (..), + UnifiedSimpleMergeable (..), + UnifiedSimpleMergeable1 (..), + UnifiedSimpleMergeable2 (..), + mrgIf, + liftBaseMonad, + mrgIte, + mrgIte1, + liftMrgIte, + mrgIte2, + liftMrgIte2, + + -- ** Unified ITE operator + UnifiedITEOp (..), + symIte, + symIteMerge, + + -- ** Unified SymEq + UnifiedSymEq (..), + (.==), + (./=), + liftSymEq, + symEq1, + liftSymEq2, + symEq2, + + -- ** Unified SymOrd + UnifiedSymOrd (..), + (.<=), + (.<), + (.>=), + (.>), + symCompare, + liftSymCompare, + symCompare1, + liftSymCompare2, + symCompare2, + symMax, + symMin, + mrgMax, + mrgMin, + + -- ** Unified safe ops + UnifiedSafeDivision (..), + safeDiv, + safeMod, + safeDivMod, + safeQuot, + safeRem, + safeQuotRem, + UnifiedSafeLinearArith (..), + safeAdd, + safeNeg, + safeSub, + UnifiedSafeSymRotate (..), + safeSymRotateL, + safeSymRotateR, + UnifiedSafeSymShift (..), + safeSymShiftL, + safeSymShiftR, + safeSymStrictShiftL, + safeSymStrictShiftR, + + -- * Unified types + + -- ** Boolean + GetBool, + + -- ** Bit-vector + GetIntN, + GetWordN, + GetSomeWordN, + GetSomeIntN, + UnifiedBV, + SafeUnifiedBV, + SafeUnifiedSomeBV, + + -- ** Integer + GetInteger, + UnifiedInteger, + + -- ** Data + GetData, + UnifiedData, + extractData, + wrapData, + ) +where + +import Grisette.Unified.Internal.BaseMonad (BaseMonad) +import Grisette.Unified.Internal.Class.UnifiedITEOp + ( UnifiedITEOp (..), + symIte, + symIteMerge, + ) +import Grisette.Unified.Internal.Class.UnifiedSafeDivision + ( UnifiedSafeDivision (..), + safeDiv, + safeDivMod, + safeMod, + safeQuot, + safeQuotRem, + safeRem, + ) +import Grisette.Unified.Internal.Class.UnifiedSafeLinearArith + ( UnifiedSafeLinearArith (..), + safeAdd, + safeNeg, + safeSub, + ) +import Grisette.Unified.Internal.Class.UnifiedSafeSymRotate + ( UnifiedSafeSymRotate (..), + safeSymRotateL, + safeSymRotateR, + ) +import Grisette.Unified.Internal.Class.UnifiedSafeSymShift + ( UnifiedSafeSymShift (..), + safeSymShiftL, + safeSymShiftR, + safeSymStrictShiftL, + safeSymStrictShiftR, + ) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedBranching (..), + UnifiedSimpleMergeable (..), + UnifiedSimpleMergeable1 (..), + UnifiedSimpleMergeable2 (..), + liftBaseMonad, + liftMrgIte, + liftMrgIte2, + mrgIf, + mrgIte, + mrgIte1, + mrgIte2, + ) +import Grisette.Unified.Internal.Class.UnifiedSymEq + ( UnifiedSymEq (..), + liftSymEq, + liftSymEq2, + symEq1, + symEq2, + (./=), + (.==), + ) +import Grisette.Unified.Internal.Class.UnifiedSymOrd + ( UnifiedSymOrd (..), + liftSymCompare, + liftSymCompare2, + mrgMax, + mrgMin, + symCompare, + symCompare1, + symCompare2, + symMax, + symMin, + (.<), + (.<=), + (.>), + (.>=), + ) +import Grisette.Unified.Internal.EvalMode (EvalMode) +import Grisette.Unified.Internal.EvalModeTag + ( EvalModeTag (..), + IsConMode, + ) +import Grisette.Unified.Internal.MonadWithMode (MonadWithMode) +import Grisette.Unified.Internal.UnifiedBV + ( GetIntN, + GetSomeIntN, + GetSomeWordN, + GetWordN, + SafeUnifiedBV, + SafeUnifiedSomeBV, + UnifiedBV, + ) +import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (..)) +import Grisette.Unified.Internal.UnifiedData + ( GetData, + UnifiedData, + extractData, + wrapData, + ) +import Grisette.Unified.Internal.UnifiedInteger + ( GetInteger, + UnifiedInteger, + ) diff --git a/src/Grisette/Unified/Internal/BaseConstraint.hs b/src/Grisette/Unified/Internal/BaseConstraint.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/BaseConstraint.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ConstraintKinds #-} + +-- | +-- Module : Grisette.Unified.Internal.EvaluationMode +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.BaseConstraint + ( BasicGrisetteType, + ConSymConversion, + ) +where + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) +import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.PPrint (PPrint) +import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym) +import Grisette.Internal.SymPrim.AllSyms (AllSyms) +import Language.Haskell.TH.Syntax (Lift) + +-- | A type that is used as a constraint for all the types in Grisette. +type BasicGrisetteType t = + ( AllSyms t, + Eq t, + EvalSym t, + ExtractSym t, + PPrint t, + Hashable t, + Lift t, + Mergeable t, + NFData t, + SymEq t, + Show t, + SymOrd t, + SubstSym t + ) + +-- | A type that is used as a constraint for all the types in Grisette that can +-- be converted between concrete and symbolic types. +type ConSymConversion conType symType t = + ( ToCon t conType, + ToSym conType t, + ToCon symType t, + ToSym t symType + ) diff --git a/src/Grisette/Unified/Internal/BaseMonad.hs b/src/Grisette/Unified/Internal/BaseMonad.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/BaseMonad.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | +-- Module : Grisette.Unified.Internal.BaseMonad +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.BaseMonad + ( BaseMonad, + ) +where + +import Control.Monad.Identity (Identity) +import Data.Kind (Type) +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) + +-- | A type family that specifies the base monad for the evaluation mode. +-- +-- Resolves to 'Identity' for `Con` mode, and 'Union' for `Sym` mode. +type family + BaseMonad (mode :: EvalModeTag) = + (r :: Type -> Type) | r -> mode + where + BaseMonad 'Con = Identity + BaseMonad 'Sym = Union diff --git a/src/Grisette/Unified/Internal/Class/UnifiedITEOp.hs b/src/Grisette/Unified/Internal/Class/UnifiedITEOp.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Class/UnifiedITEOp.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Unified.Internal.Class.UnifiedITEOp +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Class.UnifiedITEOp + ( symIte, + symIteMerge, + UnifiedITEOp (..), + ) +where + +import Control.Monad.Identity (Identity (runIdentity)) +import Data.Kind (Constraint) +import Data.Type.Bool (If) +import Data.Typeable (Typeable) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) +import qualified Grisette.Internal.Core.Data.Class.ITEOp +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import qualified Grisette.Internal.Core.Data.Class.PlainUnion +import Grisette.Unified.Internal.BaseMonad (BaseMonad) +import Grisette.Unified.Internal.EvalModeTag (IsConMode) +import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Unified.Internal.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.ITEOp.symIte` operation. +-- +-- This function isn't able to infer the mode of the boolean variable, so you +-- need to provide the mode explicitly. For example: +-- +-- > symIte @mode (a .== b) ... +-- > symIte (a .== b :: SymBool) ... +-- > symIte (a .== b :: GetBool mode) ... +symIte :: + forall mode v. + (Typeable mode, UnifiedITEOp mode v) => + GetBool mode -> + v -> + v -> + v +symIte c a b = + withMode @mode + (withBaseITEOp @mode @v $ if c then a else b) + ( withBaseITEOp @mode @v $ + Grisette.Internal.Core.Data.Class.ITEOp.symIte c a b + ) + +-- | Unified `Grisette.Internal.Core.Data.Class.PlainUnion.symIteMerge` +-- operation. +-- +-- This function isn't able to infer the mode of the base monad from the result, +-- so you need to provide the mode explicitly. For example: +-- +-- > symIteMerge @mode ... +-- > symIteMerge (... :: BaseMonad mode v) ... +symIteMerge :: + forall mode v. + (Typeable mode, UnifiedITEOp mode v, Mergeable v) => + BaseMonad mode v -> + v +symIteMerge m = + withMode @mode + (withBaseITEOp @mode @v $ runIdentity m) + ( withBaseITEOp @mode @v $ + Grisette.Internal.Core.Data.Class.PlainUnion.symIteMerge m + ) + +-- | A class that provides unified equality comparison. +-- +-- We use this type class to help resolve the constraints for `ITEOp`. +class UnifiedITEOp mode v where + withBaseITEOp :: + ((If (IsConMode mode) (() :: Constraint) (ITEOp v)) => r) -> r + +instance + ( Typeable mode, + If (IsConMode mode) (() :: Constraint) (ITEOp a) + ) => + UnifiedITEOp mode a + where + withBaseITEOp r = withMode @mode r r + {-# INLINE withBaseITEOp #-} diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeDivision.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeDivision.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Class/UnifiedSafeDivision.hs @@ -0,0 +1,264 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Unified.Internal.Class.UnifiedSafeDivision +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Class.UnifiedSafeDivision + ( safeDiv, + safeMod, + safeDivMod, + safeQuot, + safeRem, + safeQuotRem, + UnifiedSafeDivision (..), + ) +where + +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SafeDivision + ( ArithException, + SafeDivision, + ) +import qualified Grisette.Internal.Core.Data.Class.SafeDivision +import Grisette.Internal.SymPrim.BV (BitwidthMismatch, IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Unified.Internal.EvalModeTag + ( EvalModeTag (Sym), + ) +import Grisette.Unified.Internal.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDivision.safeDiv` operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeDiv @mode a b +safeDiv :: + forall mode e a m. + (MonadError e m, UnifiedSafeDivision mode e a m) => + a -> + a -> + m a +safeDiv a b = + withBaseSafeDivision @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDivision.safeDiv a b +{-# INLINE safeDiv #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDivision.safeMod` operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeMod @mode a b +safeMod :: + forall mode e a m. + (MonadError e m, UnifiedSafeDivision mode e a m) => + a -> + a -> + m a +safeMod a b = + withBaseSafeDivision @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDivision.safeMod a b +{-# INLINE safeMod #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDivision.safeDivMod` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeDivMod @mode a b +safeDivMod :: + forall mode e a m. + (MonadError e m, UnifiedSafeDivision mode e a m) => + a -> + a -> + m (a, a) +safeDivMod a b = + withBaseSafeDivision @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDivision.safeDivMod a b +{-# INLINE safeDivMod #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDivision.safeQuot` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeQuot @mode a b +safeQuot :: + forall mode e a m. + (MonadError e m, UnifiedSafeDivision mode e a m) => + a -> + a -> + m a +safeQuot a b = + withBaseSafeDivision @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDivision.safeQuot a b +{-# INLINE safeQuot #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDivision.safeRem` operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeRem @mode a b +safeRem :: + forall mode e a m. + (MonadError e m, UnifiedSafeDivision mode e a m) => + a -> + a -> + m a +safeRem a b = + withBaseSafeDivision @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDivision.safeRem a b +{-# INLINE safeRem #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeDivision.safeQuotRem` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeQuotRem @mode a b +safeQuotRem :: + forall mode e a m. + (MonadError e m, UnifiedSafeDivision mode e a m) => + a -> + a -> + m (a, a) +safeQuotRem a b = + withBaseSafeDivision @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeDivision.safeQuotRem a b +{-# INLINE safeQuotRem #-} + +-- | A class that provides unified division operations. +-- +-- We use this type class to help resolve the constraints for `SafeDivision`. +class UnifiedSafeDivision (mode :: EvalModeTag) e a m where + withBaseSafeDivision :: ((SafeDivision e a m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeDivision e a m) => + UnifiedSafeDivision mode e a m + where + withBaseSafeDivision r = r + +instance + (MonadError ArithException m, UnifiedBranching mode m) => + UnifiedSafeDivision mode ArithException Integer m + where + withBaseSafeDivision r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m) => + UnifiedSafeDivision 'Sym ArithException SymInteger m + where + withBaseSafeDivision r = withBaseBranching @'Sym @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeDivision mode ArithException (IntN n) m + where + withBaseSafeDivision r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m, KnownNat n, 1 <= n) => + UnifiedSafeDivision 'Sym ArithException (SymIntN n) m + where + withBaseSafeDivision r = withBaseBranching @'Sym @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeDivision mode ArithException (WordN n) m + where + withBaseSafeDivision r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m, KnownNat n, 1 <= n) => + UnifiedSafeDivision 'Sym ArithException (SymWordN n) m + where + withBaseSafeDivision r = withBaseBranching @'Sym @m r + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeDivision + mode + (Either BitwidthMismatch ArithException) + SomeIntN + m + where + withBaseSafeDivision r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching 'Sym m + ) => + UnifiedSafeDivision + 'Sym + (Either BitwidthMismatch ArithException) + SomeSymIntN + m + where + withBaseSafeDivision r = withBaseBranching @'Sym @m r + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeDivision + mode + (Either BitwidthMismatch ArithException) + SomeWordN + m + where + withBaseSafeDivision r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching 'Sym m + ) => + UnifiedSafeDivision + 'Sym + (Either BitwidthMismatch ArithException) + SomeSymWordN + m + where + withBaseSafeDivision r = withBaseBranching @'Sym @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeLinearArith.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeLinearArith.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Class/UnifiedSafeLinearArith.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Unified.Internal.Class.UnifiedSafeLinearArith +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Class.UnifiedSafeLinearArith + ( safeAdd, + safeNeg, + safeSub, + UnifiedSafeLinearArith (..), + ) +where + +import Control.Monad.Error.Class (MonadError) +import Data.Typeable (Typeable) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SafeLinearArith + ( ArithException, + SafeLinearArith, + ) +import qualified Grisette.Internal.Core.Data.Class.SafeLinearArith +import Grisette.Internal.SymPrim.BV (BitwidthMismatch, IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Unified.Internal.EvalModeTag + ( EvalModeTag (Sym), + ) +import Grisette.Unified.Internal.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeAdd` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeAdd @mode a b +safeAdd :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeLinearArith mode e a m + ) => + a -> + a -> + m a +safeAdd a b = + withBaseSafeLinearArith @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeLinearArith.safeAdd a b +{-# INLINE safeAdd #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeNeg` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeNeg @mode a +safeNeg :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeLinearArith mode e a m + ) => + a -> + m a +safeNeg a = + withBaseSafeLinearArith @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeLinearArith.safeNeg a +{-# INLINE safeNeg #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeLinearArith.safeSub` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSub @mode a b +safeSub :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeLinearArith mode e a m + ) => + a -> + a -> + m a +safeSub a b = + withBaseSafeLinearArith @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeLinearArith.safeSub a b +{-# INLINE safeSub #-} + +-- | A class that provides unified linear arithmetic operations. +-- +-- We use this type class to help resolve the constraints for `SafeLinearArith`. +class UnifiedSafeLinearArith (mode :: EvalModeTag) e a m where + withBaseSafeLinearArith :: ((SafeLinearArith e a m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeLinearArith e a m) => + UnifiedSafeLinearArith mode e a m + where + withBaseSafeLinearArith r = r + +instance + (Typeable mode, MonadError ArithException m, UnifiedBranching mode m) => + UnifiedSafeLinearArith mode ArithException Integer m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m) => + UnifiedSafeLinearArith 'Sym ArithException SymInteger m + where + withBaseSafeLinearArith r = withBaseBranching @'Sym @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeLinearArith mode ArithException (IntN n) m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m, KnownNat n, 1 <= n) => + UnifiedSafeLinearArith 'Sym ArithException (SymIntN n) m + where + withBaseSafeLinearArith r = withBaseBranching @'Sym @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeLinearArith mode ArithException (WordN n) m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m, KnownNat n, 1 <= n) => + UnifiedSafeLinearArith 'Sym ArithException (SymWordN n) m + where + withBaseSafeLinearArith r = withBaseBranching @'Sym @m r + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeLinearArith + mode + (Either BitwidthMismatch ArithException) + SomeIntN + m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching 'Sym m + ) => + UnifiedSafeLinearArith + 'Sym + (Either BitwidthMismatch ArithException) + SomeSymIntN + m + where + withBaseSafeLinearArith r = withBaseBranching @'Sym @m r + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeLinearArith + mode + (Either BitwidthMismatch ArithException) + SomeWordN + m + where + withBaseSafeLinearArith r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching 'Sym m + ) => + UnifiedSafeLinearArith + 'Sym + (Either BitwidthMismatch ArithException) + SomeSymWordN + m + where + withBaseSafeLinearArith r = withBaseBranching @'Sym @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeSymRotate.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeSymRotate.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Class/UnifiedSafeSymRotate.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Unified.Internal.Class.UnifiedSafeSymRotate +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Class.UnifiedSafeSymRotate + ( safeSymRotateL, + safeSymRotateR, + UnifiedSafeSymRotate (..), + ) +where + +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SafeDivision + ( ArithException, + ) +import Grisette.Internal.Core.Data.Class.SafeSymRotate (SafeSymRotate) +import qualified Grisette.Internal.Core.Data.Class.SafeSymRotate +import Grisette.Internal.SymPrim.BV (BitwidthMismatch, IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Unified.Internal.EvalModeTag + ( EvalModeTag (Sym), + ) +import Grisette.Unified.Internal.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateL` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymRotateL @mode a b +safeSymRotateL :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymRotate mode e a m + ) => + a -> + a -> + m a +safeSymRotateL a b = + withBaseSafeSymRotate @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateL a b +{-# INLINE safeSymRotateL #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateR` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymRotateR @mode a b +safeSymRotateR :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymRotate mode e a m + ) => + a -> + a -> + m a +safeSymRotateR a b = + withBaseSafeSymRotate @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymRotate.safeSymRotateR a b +{-# INLINE safeSymRotateR #-} + +-- | A class that provides unified safe symbolic rotation operations. +-- +-- We use this type class to help resolve the constraints for `SafeSymRotate`. +class UnifiedSafeSymRotate (mode :: EvalModeTag) e a m where + withBaseSafeSymRotate :: ((SafeSymRotate e a m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeSymRotate e a m) => + UnifiedSafeSymRotate mode e a m + where + withBaseSafeSymRotate r = r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeSymRotate mode ArithException (IntN n) m + where + withBaseSafeSymRotate r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m, KnownNat n, 1 <= n) => + UnifiedSafeSymRotate 'Sym ArithException (SymIntN n) m + where + withBaseSafeSymRotate r = withBaseBranching @'Sym @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeSymRotate mode ArithException (WordN n) m + where + withBaseSafeSymRotate r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m, KnownNat n, 1 <= n) => + UnifiedSafeSymRotate 'Sym ArithException (SymWordN n) m + where + withBaseSafeSymRotate r = withBaseBranching @'Sym @m r + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeSymRotate + mode + (Either BitwidthMismatch ArithException) + SomeIntN + m + where + withBaseSafeSymRotate r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching 'Sym m + ) => + UnifiedSafeSymRotate + 'Sym + (Either BitwidthMismatch ArithException) + SomeSymIntN + m + where + withBaseSafeSymRotate r = withBaseBranching @'Sym @m r + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeSymRotate + mode + (Either BitwidthMismatch ArithException) + SomeWordN + m + where + withBaseSafeSymRotate r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching 'Sym m + ) => + UnifiedSafeSymRotate + 'Sym + (Either BitwidthMismatch ArithException) + SomeSymWordN + m + where + withBaseSafeSymRotate r = withBaseBranching @'Sym @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSafeSymShift.hs b/src/Grisette/Unified/Internal/Class/UnifiedSafeSymShift.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Class/UnifiedSafeSymShift.hs @@ -0,0 +1,225 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# HLINT ignore "Eta reduce" #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +-- | +-- Module : Grisette.Unified.Internal.Class.UnifiedSafeSymShift +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Class.UnifiedSafeSymShift + ( safeSymShiftL, + safeSymShiftR, + safeSymStrictShiftL, + safeSymStrictShiftR, + UnifiedSafeSymShift (..), + ) +where + +import Control.Monad.Error.Class (MonadError) +import GHC.TypeLits (KnownNat, type (<=)) +import Grisette.Internal.Core.Data.Class.SafeDivision + ( ArithException, + ) +import Grisette.Internal.Core.Data.Class.SafeSymShift (SafeSymShift) +import qualified Grisette.Internal.Core.Data.Class.SafeSymShift +import Grisette.Internal.SymPrim.BV (BitwidthMismatch, IntN, WordN) +import Grisette.Internal.SymPrim.SomeBV + ( SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Unified.Internal.EvalModeTag + ( EvalModeTag (Sym), + ) +import Grisette.Unified.Internal.Util (withMode) + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftL` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymShiftL @mode a b +safeSymShiftL :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymShift mode e a m + ) => + a -> + a -> + m a +safeSymShiftL a b = + withBaseSafeSymShift @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftL a b +{-# INLINE safeSymShiftL #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftR` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymShiftR @mode a b +safeSymShiftR :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymShift mode e a m + ) => + a -> + a -> + m a +safeSymShiftR a b = + withBaseSafeSymShift @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymShiftR a b +{-# INLINE safeSymShiftR #-} + +-- | Unified +-- `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftL` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymStrictShiftL @mode a b +safeSymStrictShiftL :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymShift mode e a m + ) => + a -> + a -> + m a +safeSymStrictShiftL a b = + withBaseSafeSymShift @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftL a b +{-# INLINE safeSymStrictShiftL #-} + +-- | Unified +-- `Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftR` +-- operation. +-- +-- This function isn't able to infer the mode, so you need to provide the mode +-- explicitly. For example: +-- +-- > safeSymStrictShiftR @mode a b +safeSymStrictShiftR :: + forall mode e a m. + ( MonadError e m, + UnifiedSafeSymShift mode e a m + ) => + a -> + a -> + m a +safeSymStrictShiftR a b = + withBaseSafeSymShift @mode @e @a @m $ + Grisette.Internal.Core.Data.Class.SafeSymShift.safeSymStrictShiftR a b +{-# INLINE safeSymStrictShiftR #-} + +-- | A class that provides unified safe symbolic rotation operations. +-- +-- We use this type class to help resolve the constraints for `SafeSymShift`. +class UnifiedSafeSymShift (mode :: EvalModeTag) e a m where + withBaseSafeSymShift :: ((SafeSymShift e a m) => r) -> r + +instance + {-# INCOHERENT #-} + (UnifiedBranching mode m, SafeSymShift e a m) => + UnifiedSafeSymShift mode e a m + where + withBaseSafeSymShift r = r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeSymShift mode ArithException (IntN n) m + where + withBaseSafeSymShift r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m, KnownNat n, 1 <= n) => + UnifiedSafeSymShift 'Sym ArithException (SymIntN n) m + where + withBaseSafeSymShift r = withBaseBranching @'Sym @m r + +instance + (MonadError ArithException m, UnifiedBranching mode m, KnownNat n, 1 <= n) => + UnifiedSafeSymShift mode ArithException (WordN n) m + where + withBaseSafeSymShift r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + (MonadError ArithException m, UnifiedBranching 'Sym m, KnownNat n, 1 <= n) => + UnifiedSafeSymShift 'Sym ArithException (SymWordN n) m + where + withBaseSafeSymShift r = withBaseBranching @'Sym @m r + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeSymShift + mode + (Either BitwidthMismatch ArithException) + SomeIntN + m + where + withBaseSafeSymShift r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching 'Sym m + ) => + UnifiedSafeSymShift + 'Sym + (Either BitwidthMismatch ArithException) + SomeSymIntN + m + where + withBaseSafeSymShift r = withBaseBranching @'Sym @m r + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching mode m + ) => + UnifiedSafeSymShift + mode + (Either BitwidthMismatch ArithException) + SomeWordN + m + where + withBaseSafeSymShift r = + withMode @mode (withBaseBranching @mode @m r) (withBaseBranching @mode @m r) + +instance + ( MonadError (Either BitwidthMismatch ArithException) m, + UnifiedBranching 'Sym m + ) => + UnifiedSafeSymShift + 'Sym + (Either BitwidthMismatch ArithException) + SomeSymWordN + m + where + withBaseSafeSymShift r = withBaseBranching @'Sym @m r diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSimpleMergeable.hs b/src/Grisette/Unified/Internal/Class/UnifiedSimpleMergeable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Class/UnifiedSimpleMergeable.hs @@ -0,0 +1,796 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Unified.Internal.Class.UnifiedSimpleMergeable +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedBranching (..), + UnifiedSimpleMergeable (..), + UnifiedSimpleMergeable1 (..), + UnifiedSimpleMergeable2 (..), + mrgIf, + liftBaseMonad, + mrgIte, + mrgIte1, + liftMrgIte, + mrgIte2, + liftMrgIte2, + ) +where + +import Control.Monad.Cont (ContT) +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity (Identity (runIdentity), IdentityT) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Trans.RWS.Lazy as RWSLazy +import qualified Control.Monad.Trans.RWS.Strict as RWSStrict +import Control.Monad.Trans.Reader (ReaderT) +import qualified Control.Monad.Trans.State.Lazy as StateLazy +import qualified Control.Monad.Trans.State.Strict as StateStrict +import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy +import qualified Control.Monad.Trans.Writer.Strict as WriterStrict +import Data.Kind (Constraint) +import Data.Type.Bool (If) +import Data.Typeable (Typeable) +import Grisette.Internal.Core.Control.Exception (AssertionError) +import Grisette.Internal.Core.Control.Monad.Union (liftUnion) +import Grisette.Internal.Core.Data.Class.GenSym (FreshT) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SimpleMergeable + ( SimpleMergeable, + SimpleMergeable1, + SimpleMergeable2, + SymBranching, + ) +import qualified Grisette.Internal.Core.Data.Class.SimpleMergeable +import qualified Grisette.Internal.Core.Data.Class.SimpleMergeable as Grisette +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingle, + ) +import Grisette.Internal.TH.DeriveUnifiedInterface + ( deriveFunctorArgUnifiedInterfaces, + deriveUnifiedInterface1s, + ) +import Grisette.Unified.Internal.BaseMonad (BaseMonad) +import Grisette.Unified.Internal.EvalModeTag + ( EvalModeTag, + IsConMode, + ) +import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Unified.Internal.Util (withMode) + +-- | Unified `Grisette.mrgIf`. +-- +-- This function isn't able to infer the mode of the boolean variable, so you +-- need to provide the mode explicitly. For example: +-- +-- > mrgIf @mode (a .== b) ... +-- > mrgIf (a .== b :: SymBool) ... +-- > mrgIf (a .== b :: GetBool mode) ... +mrgIf :: + forall mode a m. + (Typeable mode, Mergeable a, UnifiedBranching mode m) => + GetBool mode -> + m a -> + m a -> + m a +mrgIf c t e = + withMode @mode + (if c then t else e) + (withBaseBranching @mode @m $ Grisette.mrgIf c t e) +{-# INLINE mrgIf #-} + +-- | Unified lifting of a base monad. +liftBaseMonad :: + forall mode a m. + ( Applicative m, + UnifiedBranching mode m, + Mergeable a + ) => + BaseMonad mode a -> + m a +liftBaseMonad b = + withMode @mode + (withBaseBranching @mode @m $ mrgSingle . runIdentity $ b) + (withBaseBranching @mode @m $ liftUnion b) +{-# INLINE liftBaseMonad #-} + +-- | Unified `Grisette.mrgIte`. +mrgIte :: + forall mode a. + (Typeable mode, UnifiedSimpleMergeable mode a) => + GetBool mode -> + a -> + a -> + a +mrgIte c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable @mode @a $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIte c t e + ) + +-- | Unified `Grisette.mrgIte1`. +mrgIte1 :: + forall mode f a. + ( Typeable mode, + UnifiedSimpleMergeable1 mode f, + UnifiedSimpleMergeable mode a + ) => + GetBool mode -> + f a -> + f a -> + f a +mrgIte1 c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable @mode @a $ + withBaseSimpleMergeable1 @mode @f $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIte1 c t e + ) + +-- | Unified `Grisette.liftMrgIte`. +liftMrgIte :: + forall mode f a. + ( Typeable mode, + UnifiedSimpleMergeable1 mode f + ) => + (GetBool mode -> a -> a -> a) -> + GetBool mode -> + f a -> + f a -> + f a +liftMrgIte f c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable1 @mode @f $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.liftMrgIte f c t e + ) + +-- | Unified `Grisette.mrgIte2`. +mrgIte2 :: + forall mode f a b. + ( Typeable mode, + UnifiedSimpleMergeable2 mode f, + UnifiedSimpleMergeable mode a, + UnifiedSimpleMergeable mode b + ) => + GetBool mode -> + f a b -> + f a b -> + f a b +mrgIte2 c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable @mode @a $ + withBaseSimpleMergeable @mode @b $ + withBaseSimpleMergeable2 @mode @f $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.mrgIte2 c t e + ) + +-- | Unified `Grisette.liftMrgIte2`. +liftMrgIte2 :: + forall mode f a b. + ( Typeable mode, + UnifiedSimpleMergeable2 mode f + ) => + (GetBool mode -> a -> a -> a) -> + (GetBool mode -> b -> b -> b) -> + GetBool mode -> + f a b -> + f a b -> + f a b +liftMrgIte2 f g c t e = + withMode @mode + (if c then t else e) + ( withBaseSimpleMergeable2 @mode @f $ + Grisette.Internal.Core.Data.Class.SimpleMergeable.liftMrgIte2 f g c t e + ) + +-- | A class that provides a unified simple merging. +-- +-- We use this type class to help resolve the constraints for `SimpleMergeable`. +class UnifiedSimpleMergeable mode a where + withBaseSimpleMergeable :: + ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable a)) => r) -> r + +-- | A class that provides lifting of unified simple merging. +-- +-- We use this type class to help resolve the constraints for +-- `SimpleMergeable1`. +class UnifiedSimpleMergeable1 mode f where + withBaseSimpleMergeable1 :: + ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable1 f)) => r) -> r + +-- | A class that provides lifting of unified simple merging. +-- +-- We use this type class to help resolve the constraints for +-- `SimpleMergeable2`. +class UnifiedSimpleMergeable2 mode f where + withBaseSimpleMergeable2 :: + ((If (IsConMode mode) (() :: Constraint) (SimpleMergeable2 f)) => r) -> r + +-- | A class that provides a unified branching operation. +-- +-- We use this type class to help resolve the constraints for +-- `SymBranching`. +class + (Typeable mode) => + UnifiedBranching (mode :: EvalModeTag) m + where + withBaseBranching :: + ((If (IsConMode mode) (TryMerge m) (SymBranching m)) => r) -> r + +instance + {-# INCOHERENT #-} + ( Typeable mode, + If (IsConMode mode) ((TryMerge m) :: Constraint) (SymBranching m) + ) => + UnifiedBranching mode m + where + withBaseBranching r = r + {-# INLINE withBaseBranching #-} + +instance + {-# INCOHERENT #-} + ( Typeable mode, + If (IsConMode mode) (() :: Constraint) (SimpleMergeable m) + ) => + UnifiedSimpleMergeable mode m + where + withBaseSimpleMergeable r = r + {-# INLINE withBaseSimpleMergeable #-} + +instance + {-# INCOHERENT #-} + ( Typeable mode, + If (IsConMode mode) (() :: Constraint) (SimpleMergeable1 m) + ) => + UnifiedSimpleMergeable1 mode m + where + withBaseSimpleMergeable1 r = r + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + {-# INCOHERENT #-} + ( Typeable mode, + If (IsConMode mode) (() :: Constraint) (SimpleMergeable2 m) + ) => + UnifiedSimpleMergeable2 mode m + where + withBaseSimpleMergeable2 r = r + {-# INLINE withBaseSimpleMergeable2 #-} + +deriveFunctorArgUnifiedInterfaces + ''UnifiedSimpleMergeable + 'withBaseSimpleMergeable + ''UnifiedSimpleMergeable1 + 'withBaseSimpleMergeable1 + [ ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''Identity + ] + +deriveUnifiedInterface1s + ''UnifiedSimpleMergeable + 'withBaseSimpleMergeable + ''UnifiedSimpleMergeable1 + 'withBaseSimpleMergeable1 + [ ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''Identity + ] + +instance (Typeable mode) => UnifiedSimpleMergeable2 mode (,) where + withBaseSimpleMergeable2 r = withMode @mode r r + {-# INLINE withBaseSimpleMergeable2 #-} + +instance + (Typeable mode, UnifiedSimpleMergeable mode a) => + UnifiedSimpleMergeable2 mode ((,,) a) + where + withBaseSimpleMergeable2 r = + withMode @mode + (withBaseSimpleMergeable @mode @a r) + (withBaseSimpleMergeable @mode @a r) + {-# INLINE withBaseSimpleMergeable2 #-} + +instance + ( Typeable mode, + UnifiedSimpleMergeable mode a, + UnifiedSimpleMergeable mode b + ) => + UnifiedSimpleMergeable2 mode ((,,,) a b) + where + withBaseSimpleMergeable2 r = + withMode @mode + (withBaseSimpleMergeable @mode @a $ withBaseSimpleMergeable @mode @b r) + (withBaseSimpleMergeable @mode @a $ withBaseSimpleMergeable @mode @b r) + {-# INLINE withBaseSimpleMergeable2 #-} + +instance + (Typeable mode, UnifiedSimpleMergeable mode b) => + UnifiedSimpleMergeable mode (a -> b) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseSimpleMergeable @mode @b r) + (withBaseSimpleMergeable @mode @b r) + {-# INLINE withBaseSimpleMergeable #-} + +instance (Typeable mode) => UnifiedSimpleMergeable1 mode ((->) a) where + withBaseSimpleMergeable1 r = withMode @mode r r + {-# INLINE withBaseSimpleMergeable1 #-} + +instance (Typeable mode) => UnifiedSimpleMergeable2 mode (->) where + withBaseSimpleMergeable2 r = withMode @mode r r + {-# INLINE withBaseSimpleMergeable2 #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable a) => + UnifiedSimpleMergeable mode (FreshT m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m) => + UnifiedSimpleMergeable1 mode (FreshT m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (Typeable mode, UnifiedBranching mode m) => + UnifiedBranching mode (FreshT m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable a) => + UnifiedSimpleMergeable mode (MaybeT m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m) => + UnifiedSimpleMergeable1 mode (MaybeT m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (Typeable mode, UnifiedBranching mode m) => + UnifiedBranching mode (MaybeT m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable a) => + UnifiedSimpleMergeable mode (IdentityT m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m) => + UnifiedSimpleMergeable1 mode (IdentityT m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (Typeable mode, UnifiedBranching mode m) => + UnifiedBranching mode (IdentityT m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable a) => + UnifiedSimpleMergeable mode (ReaderT r m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m) => + UnifiedSimpleMergeable1 mode (ReaderT r m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (Typeable mode, UnifiedBranching mode m) => + UnifiedBranching mode (ReaderT r m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable s, Mergeable a) => + UnifiedSimpleMergeable mode (StateLazy.StateT s m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable s) => + UnifiedSimpleMergeable1 mode (StateLazy.StateT s m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable s + ) => + UnifiedBranching mode (StateLazy.StateT s m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable s, Mergeable a) => + UnifiedSimpleMergeable mode (StateStrict.StateT s m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable s) => + UnifiedSimpleMergeable1 mode (StateStrict.StateT s m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable s + ) => + UnifiedBranching mode (StateStrict.StateT s m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable w, + Mergeable a, + Monoid w + ) => + UnifiedSimpleMergeable mode (WriterLazy.WriterT w m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable w, Monoid w) => + UnifiedSimpleMergeable1 mode (WriterLazy.WriterT w m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Monoid w, + Mergeable w + ) => + UnifiedBranching mode (WriterLazy.WriterT w m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable w, + Mergeable a, + Monoid w + ) => + UnifiedSimpleMergeable mode (WriterStrict.WriterT w m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable w, Monoid w) => + UnifiedSimpleMergeable1 mode (WriterStrict.WriterT w m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Monoid w, + Mergeable w + ) => + UnifiedBranching mode (WriterStrict.WriterT w m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable e, + Mergeable a + ) => + UnifiedSimpleMergeable mode (ExceptT e m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable e) => + UnifiedSimpleMergeable1 mode (ExceptT e m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (Typeable mode, Mergeable e, UnifiedBranching mode m) => + UnifiedBranching mode (ExceptT e m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable r, + Mergeable a + ) => + UnifiedSimpleMergeable mode (ContT r m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + (Typeable mode, UnifiedBranching mode m, Mergeable r) => + UnifiedSimpleMergeable1 mode (ContT r m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + (Typeable mode, Mergeable r, UnifiedBranching mode m) => + UnifiedBranching mode (ContT r m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable s, + Mergeable a + ) => + UnifiedSimpleMergeable mode (RWSLazy.RWST r w s m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable s + ) => + UnifiedSimpleMergeable1 mode (RWSLazy.RWST r w s m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable s, + Monoid w, + Mergeable w + ) => + UnifiedBranching mode (RWSLazy.RWST r w s m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable s, + Mergeable a + ) => + UnifiedSimpleMergeable mode (RWSStrict.RWST r w s m a) + where + withBaseSimpleMergeable r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable w, + Monoid w, + Mergeable s + ) => + UnifiedSimpleMergeable1 mode (RWSStrict.RWST r w s m) + where + withBaseSimpleMergeable1 r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseSimpleMergeable1 #-} + +instance + ( Typeable mode, + UnifiedBranching mode m, + Mergeable s, + Monoid w, + Mergeable w + ) => + UnifiedBranching mode (RWSStrict.RWST r w s m) + where + withBaseBranching r = + withMode @mode + (withBaseBranching @mode @m r) + (withBaseBranching @mode @m r) + {-# INLINE withBaseBranching #-} diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs b/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Class/UnifiedSymEq.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Unified.Internal.Class.UnifiedSymEq +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Class.UnifiedSymEq + ( UnifiedSymEq (..), + UnifiedSymEq1 (..), + UnifiedSymEq2 (..), + (.==), + (./=), + liftSymEq, + symEq1, + liftSymEq2, + symEq2, + ) +where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity (Identity, IdentityT) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Classes (Eq1 (liftEq), Eq2 (liftEq2), eq1, eq2) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T +import Data.Type.Bool (If) +import Data.Typeable (Typeable) +import Data.Word (Word16, Word32, Word64, Word8) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq, SymEq1, SymEq2) +import qualified Grisette.Internal.Core.Data.Class.SymEq +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.TH.DeriveUnifiedInterface + ( deriveFunctorArgUnifiedInterfaces, + deriveUnifiedInterface1s, + ) +import Grisette.Unified.Internal.EvalModeTag (IsConMode) +import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Unified.Internal.Util (withMode) + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymEq..==)`. +-- +-- Note that you may sometimes need to write type annotations for the result +-- when the mode isn't clear: +-- +-- > a .== b :: GetBool mode +-- +-- One example when it isn't clear is when this is used in unified +-- `Grisette.Unified.Internal.Class.UnifiedBranching.mrgIf`. +(.==) :: + forall mode a. (Typeable mode, UnifiedSymEq mode a) => a -> a -> GetBool mode +(.==) a b = + withMode @mode + (withBaseSymEq @mode @a $ a == b) + (withBaseSymEq @mode @a $ a Grisette.Internal.Core.Data.Class.SymEq..== b) + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymEq../=)`. +-- +-- Note that you may sometimes need to write type annotations for the result +-- when the mode isn't clear: +-- +-- > a ./= b :: GetBool mode +-- +-- One example when it isn't clear is when this is used in unified +-- `Grisette.Unified.Internal.Class.UnifiedBranching.mrgIf`. +(./=) :: + forall mode a. (Typeable mode, UnifiedSymEq mode a) => a -> a -> GetBool mode +(./=) a b = + withMode @mode + (withBaseSymEq @mode @a $ a /= b) + (withBaseSymEq @mode @a $ a Grisette.Internal.Core.Data.Class.SymEq../= b) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.liftSymEq`. +liftSymEq :: + forall mode f a b. + (Typeable mode, UnifiedSymEq1 mode f) => + (a -> b -> GetBool mode) -> + f a -> + f b -> + GetBool mode +liftSymEq f a b = + withMode @mode + (withBaseSymEq1 @mode @f $ liftEq f a b) + ( withBaseSymEq1 @mode @f $ + Grisette.Internal.Core.Data.Class.SymEq.liftSymEq f a b + ) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symEq1`. +symEq1 :: + forall mode f a. + (Typeable mode, UnifiedSymEq mode a, UnifiedSymEq1 mode f) => + f a -> + f a -> + GetBool mode +symEq1 a b = + withMode @mode + (withBaseSymEq1 @mode @f $ withBaseSymEq @mode @a eq1 a b) + ( withBaseSymEq1 @mode @f $ + withBaseSymEq @mode @a $ + Grisette.Internal.Core.Data.Class.SymEq.symEq1 a b + ) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.liftSymEq2`. +liftSymEq2 :: + forall mode f a b c d. + (Typeable mode, UnifiedSymEq2 mode f) => + (a -> b -> GetBool mode) -> + (c -> d -> GetBool mode) -> + f a c -> + f b d -> + GetBool mode +liftSymEq2 f a b = + withMode @mode + (withBaseSymEq2 @mode @f $ liftEq2 f a b) + ( withBaseSymEq2 @mode @f $ + Grisette.Internal.Core.Data.Class.SymEq.liftSymEq2 f a b + ) + +-- | Unified `Grisette.Internal.Core.Data.Class.SymEq.symEq2`. +symEq2 :: + forall mode f a b. + ( Typeable mode, + UnifiedSymEq mode a, + UnifiedSymEq mode b, + UnifiedSymEq2 mode f + ) => + f a b -> + f a b -> + GetBool mode +symEq2 a b = + withMode @mode + ( withBaseSymEq2 @mode @f $ + withBaseSymEq @mode @a $ + withBaseSymEq @mode @b eq2 a b + ) + ( withBaseSymEq2 @mode @f $ + withBaseSymEq @mode @a $ + withBaseSymEq @mode @b $ + Grisette.Internal.Core.Data.Class.SymEq.symEq2 a b + ) + +-- | A class that provides unified equality comparison. +-- +-- We use this type class to help resolve the constraints for `Eq` and `SymEq`. +class UnifiedSymEq mode a where + withBaseSymEq :: ((If (IsConMode mode) (Eq a) (SymEq a)) => r) -> r + +-- | A class that provides unified lifting of equality comparison. +-- +-- We use this type class to help resolve the constraints for `Eq1` and +-- `SymEq1`. +class + (forall a. (UnifiedSymEq mode a) => UnifiedSymEq mode (f a)) => + UnifiedSymEq1 mode f + where + withBaseSymEq1 :: ((If (IsConMode mode) (Eq1 f) (SymEq1 f)) => r) -> r + +-- | A class that provides unified lifting of equality comparison. +-- +-- We use this type class to help resolve the constraints for `Eq2` and +-- `SymEq2`. +class + (forall a. (UnifiedSymEq mode a) => UnifiedSymEq1 mode (f a)) => + UnifiedSymEq2 mode f + where + withBaseSymEq2 :: ((If (IsConMode mode) (Eq2 f) (SymEq2 f)) => r) -> r + +instance + {-# INCOHERENT #-} + (Typeable mode, If (IsConMode mode) (Eq a) (SymEq a)) => + UnifiedSymEq mode a + where + withBaseSymEq r = r + {-# INLINE withBaseSymEq #-} + +instance + {-# INCOHERENT #-} + ( Typeable mode, + If (IsConMode mode) (Eq1 f) (SymEq1 f), + forall a. (UnifiedSymEq mode a) => UnifiedSymEq mode (f a) + ) => + UnifiedSymEq1 mode f + where + withBaseSymEq1 r = r + {-# INLINE withBaseSymEq1 #-} + +instance + {-# INCOHERENT #-} + ( Typeable mode, + If (IsConMode mode) (Eq2 f) (SymEq2 f), + forall a. (UnifiedSymEq mode a) => UnifiedSymEq1 mode (f a) + ) => + UnifiedSymEq2 mode f + where + withBaseSymEq2 r = r + {-# INLINE withBaseSymEq2 #-} + +deriveFunctorArgUnifiedInterfaces + ''UnifiedSymEq + 'withBaseSymEq + ''UnifiedSymEq1 + 'withBaseSymEq1 + [ ''Bool, + ''Integer, + ''Char, + ''Int, + ''Int8, + ''Int16, + ''Int32, + ''Int64, + ''Word, + ''Word8, + ''Word16, + ''Word32, + ''Word64, + ''Float, + ''Double, + ''B.ByteString, + ''T.Text, + ''FPRoundingMode, + ''WordN, + ''IntN, + ''[], + ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT, + ''Identity + ] + +deriveUnifiedInterface1s + ''UnifiedSymEq + 'withBaseSymEq + ''UnifiedSymEq1 + 'withBaseSymEq1 + [ ''[], + ''Maybe, + ''Either, + ''(,), + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT, + ''Identity + ] + +-- Sum +instance + ( Typeable mode, + UnifiedSymEq1 mode f, + UnifiedSymEq1 mode g, + UnifiedSymEq mode a + ) => + UnifiedSymEq mode (Sum f g a) + where + withBaseSymEq r = + withMode @mode + ( withBaseSymEq1 @mode @f $ + withBaseSymEq1 @mode @g $ + withBaseSymEq @mode @a r + ) + ( withBaseSymEq1 @mode @f $ + withBaseSymEq1 @mode @g $ + withBaseSymEq @mode @a r + ) + {-# INLINE withBaseSymEq #-} + +instance + (Typeable mode, UnifiedSymEq1 mode f, UnifiedSymEq1 mode g) => + UnifiedSymEq1 mode (Sum f g) + where + withBaseSymEq1 r = + withMode @mode + (withBaseSymEq1 @mode @f $ withBaseSymEq1 @mode @g r) + (withBaseSymEq1 @mode @f $ withBaseSymEq1 @mode @g r) + {-# INLINE withBaseSymEq1 #-} + +-- IdentityT +instance + (Typeable mode, UnifiedSymEq1 mode m, UnifiedSymEq mode a) => + UnifiedSymEq mode (IdentityT m a) + where + withBaseSymEq r = + withMode @mode + (withBaseSymEq1 @mode @m $ withBaseSymEq @mode @a r) + (withBaseSymEq1 @mode @m $ withBaseSymEq @mode @a r) + {-# INLINE withBaseSymEq #-} + +instance + (Typeable mode, UnifiedSymEq1 mode m) => + UnifiedSymEq1 mode (IdentityT m) + where + withBaseSymEq1 r = + withMode @mode (withBaseSymEq1 @mode @m r) (withBaseSymEq1 @mode @m r) + {-# INLINE withBaseSymEq1 #-} + +instance (Typeable mode, ValidFP eb sb) => UnifiedSymEq mode (FP eb sb) where + withBaseSymEq r = withMode @mode r r + {-# INLINE withBaseSymEq #-} + +instance (Typeable mode) => UnifiedSymEq2 mode Either where + withBaseSymEq2 r = withMode @mode r r + {-# INLINE withBaseSymEq2 #-} + +instance (Typeable mode) => UnifiedSymEq2 mode (,) where + withBaseSymEq2 r = withMode @mode r r + {-# INLINE withBaseSymEq2 #-} + +#if MIN_VERSION_base(4,16,0) +deriveUnifiedInterface1s + ''UnifiedSymEq + 'withBaseSymEq + ''UnifiedSymEq1 + 'withBaseSymEq1 + [ ''(,,), + ''(,,,) + ] + +instance (Typeable mode, UnifiedSymEq mode a) => + UnifiedSymEq2 mode ((,,) a) where + withBaseSymEq2 r = + withMode @mode (withBaseSymEq @mode @a r) (withBaseSymEq @mode @a r) + {-# INLINE withBaseSymEq2 #-} + +instance + (Typeable mode, UnifiedSymEq mode a, UnifiedSymEq mode b) => + UnifiedSymEq2 mode ((,,,) a b) + where + withBaseSymEq2 r = + withMode @mode + (withBaseSymEq @mode @a $ withBaseSymEq @mode @b r) + (withBaseSymEq @mode @a $ withBaseSymEq @mode @b r) + {-# INLINE withBaseSymEq2 #-} +#endif diff --git a/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs b/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Class/UnifiedSymOrd.hs @@ -0,0 +1,527 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Unified.Internal.Class.UnifiedSymOrd +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Class.UnifiedSymOrd + ( UnifiedSymOrd (..), + UnifiedSymOrd1 (..), + UnifiedSymOrd2 (..), + (.<=), + (.<), + (.>=), + (.>), + symCompare, + liftSymCompare, + symCompare1, + liftSymCompare2, + symCompare2, + symMax, + symMin, + mrgMax, + mrgMin, + ) +where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity (Identity (runIdentity), IdentityT) +import Control.Monad.Trans.Maybe (MaybeT) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Classes + ( Ord1 (liftCompare), + Ord2 (liftCompare2), + compare1, + compare2, + ) +import Data.Functor.Sum (Sum) +import Data.Int (Int16, Int32, Int64, Int8) +import qualified Data.Text as T +import Data.Type.Bool (If) +import Data.Typeable (Typeable) +import Data.Word (Word16, Word32, Word64, Word8) +import Grisette.Internal.Core.Control.Exception + ( AssertionError, + VerificationConditions, + ) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd, SymOrd1, SymOrd2) +import qualified Grisette.Internal.Core.Data.Class.SymOrd +import Grisette.Internal.Core.Data.Class.TryMerge (tryMerge) +import Grisette.Internal.SymPrim.BV (IntN, WordN) +import Grisette.Internal.SymPrim.FP (FP, FPRoundingMode, ValidFP) +import Grisette.Internal.TH.DeriveUnifiedInterface + ( deriveFunctorArgUnifiedInterfaces, + deriveUnifiedInterface1s, + ) +import Grisette.Unified.Internal.BaseMonad (BaseMonad) +import Grisette.Unified.Internal.Class.UnifiedITEOp + ( UnifiedITEOp (withBaseITEOp), + ) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + ) +import Grisette.Unified.Internal.EvalModeTag + ( IsConMode, + ) +import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Unified.Internal.Util (withMode) + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..<=)`. +-- +-- Note that you may sometimes need to write type annotations for the result +-- when the mode isn't clear: +-- +-- > a .<= b :: GetBool mode +-- +-- One example when it isn't clear is when this is used in unified +-- `Grisette.Unified.Internal.Class.UnifiedBranching.mrgIf`. +(.<=) :: + forall mode a. (Typeable mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode +(.<=) a b = + withMode @mode + (withBaseSymOrd @mode @a $ a <= b) + (withBaseSymOrd @mode @a $ a Grisette.Internal.Core.Data.Class.SymOrd..<= b) +{-# INLINE (.<=) #-} + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..<)`. +(.<) :: + forall mode a. (Typeable mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode +(.<) a b = + withMode @mode + (withBaseSymOrd @mode @a $ a < b) + (withBaseSymOrd @mode @a $ a Grisette.Internal.Core.Data.Class.SymOrd..< b) +{-# INLINE (.<) #-} + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..>=)`. +(.>=) :: + forall mode a. (Typeable mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode +(.>=) a b = + withMode @mode + (withBaseSymOrd @mode @a $ a >= b) + (withBaseSymOrd @mode @a $ a Grisette.Internal.Core.Data.Class.SymOrd..>= b) +{-# INLINE (.>=) #-} + +-- | Unified `(Grisette.Internal.Core.Data.Class.SymOrd..>)`. +(.>) :: + forall mode a. (Typeable mode, UnifiedSymOrd mode a) => a -> a -> GetBool mode +(.>) a b = + withMode @mode + (withBaseSymOrd @mode @a $ a > b) + (withBaseSymOrd @mode @a $ a Grisette.Internal.Core.Data.Class.SymOrd..> b) +{-# INLINE (.>) #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare`. +symCompare :: + forall mode a ctx. + (Typeable mode, UnifiedSymOrd mode a, Monad ctx) => + a -> + a -> + BaseMonad mode Ordering +symCompare x y = + withMode @mode + (withBaseSymOrd @mode @a $ return $ compare x y) + ( withBaseSymOrd @mode @a $ + Grisette.Internal.Core.Data.Class.SymOrd.symCompare x y + ) +{-# INLINE symCompare #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare`. +liftSymCompare :: + forall mode f a b. + (Typeable mode, UnifiedSymOrd1 mode f) => + (a -> b -> BaseMonad mode Ordering) -> + f a -> + f b -> + BaseMonad mode Ordering +liftSymCompare f a b = + withMode @mode + ( withBaseSymOrd1 @mode @f $ + return $ + liftCompare (\x y -> runIdentity $ f x y) a b + ) + ( withBaseSymOrd1 @mode @f $ + Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare f a b + ) +{-# INLINE liftSymCompare #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare1`. +symCompare1 :: + forall mode f a. + (Typeable mode, UnifiedSymOrd mode a, UnifiedSymOrd1 mode f) => + f a -> + f a -> + BaseMonad mode Ordering +symCompare1 a b = + withMode @mode + (withBaseSymOrd1 @mode @f $ withBaseSymOrd @mode @a $ return $ compare1 a b) + ( withBaseSymOrd1 @mode @f $ + withBaseSymOrd @mode @a $ + Grisette.Internal.Core.Data.Class.SymOrd.symCompare1 a b + ) +{-# INLINE symCompare1 #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare2`. +liftSymCompare2 :: + forall mode f a b c d. + (Typeable mode, UnifiedSymOrd2 mode f) => + (a -> b -> BaseMonad mode Ordering) -> + (c -> d -> BaseMonad mode Ordering) -> + f a c -> + f b d -> + BaseMonad mode Ordering +liftSymCompare2 f g a b = + withMode @mode + ( withBaseSymOrd2 @mode @f $ + return $ + liftCompare2 + (\x y -> runIdentity $ f x y) + (\x y -> runIdentity $ g x y) + a + b + ) + ( withBaseSymOrd2 @mode @f $ + Grisette.Internal.Core.Data.Class.SymOrd.liftSymCompare2 f g a b + ) +{-# INLINE liftSymCompare2 #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symCompare2`. +symCompare2 :: + forall mode f a b. + ( Typeable mode, + UnifiedSymOrd mode a, + UnifiedSymOrd mode b, + UnifiedSymOrd2 mode f + ) => + f a b -> + f a b -> + BaseMonad mode Ordering +symCompare2 a b = + withMode @mode + ( withBaseSymOrd2 @mode @f $ + withBaseSymOrd @mode @a $ + withBaseSymOrd @mode @b $ + return $ + compare2 a b + ) + ( withBaseSymOrd2 @mode @f $ + withBaseSymOrd @mode @a $ + withBaseSymOrd @mode @b $ + Grisette.Internal.Core.Data.Class.SymOrd.symCompare2 a b + ) +{-# INLINE symCompare2 #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symMax`. +symMax :: + forall mode a. + (UnifiedSymOrd mode a, UnifiedITEOp mode a, Typeable mode) => + a -> + a -> + a +symMax x y = + withMode @mode + (withBaseSymOrd @mode @a $ max x y) + ( withBaseSymOrd @mode @a $ + withBaseITEOp @mode @a + Grisette.Internal.Core.Data.Class.SymOrd.symMax + x + y + ) +{-# INLINE symMax #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.symMin`. +symMin :: + forall mode a. + (UnifiedSymOrd mode a, UnifiedITEOp mode a, Typeable mode) => + a -> + a -> + a +symMin x y = + withMode @mode + (withBaseSymOrd @mode @a $ min x y) + ( withBaseSymOrd @mode @a $ + withBaseITEOp @mode @a + Grisette.Internal.Core.Data.Class.SymOrd.symMin + x + y + ) +{-# INLINE symMin #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.mrgMax`. +mrgMax :: + forall mode a m. + ( UnifiedSymOrd mode a, + UnifiedBranching mode m, + Typeable mode, + Applicative m, + Mergeable a + ) => + a -> + a -> + m a +mrgMax x y = + withMode @mode + ( withBaseSymOrd @mode @a $ + withBaseBranching @mode @m $ + tryMerge $ + pure $ + max x y + ) + ( withBaseSymOrd @mode @a $ + withBaseBranching @mode @m $ + Grisette.Internal.Core.Data.Class.SymOrd.mrgMax x y + ) +{-# INLINE mrgMax #-} + +-- | Unified `Grisette.Internal.Core.Data.Class.SymOrd.mrgMin`. +mrgMin :: + forall mode a m. + ( UnifiedSymOrd mode a, + UnifiedBranching mode m, + Typeable mode, + Applicative m, + Mergeable a + ) => + a -> + a -> + m a +mrgMin x y = + withMode @mode + ( withBaseSymOrd @mode @a $ + withBaseBranching @mode @m $ + tryMerge $ + pure $ + min x y + ) + ( withBaseSymOrd @mode @a $ + withBaseBranching @mode @m $ + Grisette.Internal.Core.Data.Class.SymOrd.mrgMin x y + ) +{-# INLINE mrgMin #-} + +-- | A class that provides unified comparison. +-- +-- We use this type class to help resolve the constraints for `Ord` and +-- `SymOrd`. +class UnifiedSymOrd mode a where + withBaseSymOrd :: (((If (IsConMode mode) (Ord a) (SymOrd a)) => r)) -> r + +-- | A class that provides unified lifting of comparison. +-- +-- We use this type class to help resolve the constraints for `Ord1` and +-- `SymOrd1`. +class UnifiedSymOrd1 mode f where + withBaseSymOrd1 :: (((If (IsConMode mode) (Ord1 f) (SymOrd1 f)) => r)) -> r + +-- | A class that provides unified lifting of comparison. +-- +-- We use this type class to help resolve the constraints for `Ord2` and +-- `SymOrd2`. +class UnifiedSymOrd2 mode f where + withBaseSymOrd2 :: (((If (IsConMode mode) (Ord2 f) (SymOrd2 f)) => r)) -> r + +instance + {-# INCOHERENT #-} + (Typeable mode, If (IsConMode mode) (Ord a) (SymOrd a)) => + UnifiedSymOrd mode a + where + withBaseSymOrd r = r + {-# INLINE withBaseSymOrd #-} + +instance + {-# INCOHERENT #-} + ( Typeable mode, + If (IsConMode mode) (Ord1 f) (SymOrd1 f), + forall a. (UnifiedSymOrd mode a) => UnifiedSymOrd mode (f a) + ) => + UnifiedSymOrd1 mode f + where + withBaseSymOrd1 r = r + {-# INLINE withBaseSymOrd1 #-} + +instance + {-# INCOHERENT #-} + ( Typeable mode, + If (IsConMode mode) (Ord2 f) (SymOrd2 f), + forall a. (UnifiedSymOrd mode a) => UnifiedSymOrd1 mode (f a) + ) => + UnifiedSymOrd2 mode f + where + withBaseSymOrd2 r = r + {-# INLINE withBaseSymOrd2 #-} + +deriveFunctorArgUnifiedInterfaces + ''UnifiedSymOrd + 'withBaseSymOrd + ''UnifiedSymOrd1 + 'withBaseSymOrd1 + [ ''Bool, + ''Integer, + ''Char, + ''Int, + ''Int8, + ''Int16, + ''Int32, + ''Int64, + ''Word, + ''Word8, + ''Word16, + ''Word32, + ''Word64, + ''Float, + ''Double, + ''B.ByteString, + ''T.Text, + ''FPRoundingMode, + ''WordN, + ''IntN, + ''[], + ''Maybe, + ''Either, + ''(), + ''(,), + ''(,,), + ''(,,,), + ''(,,,,), + ''(,,,,,), + ''(,,,,,,), + ''(,,,,,,,), + ''(,,,,,,,,), + ''(,,,,,,,,,), + ''(,,,,,,,,,,), + ''(,,,,,,,,,,,), + ''(,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,), + ''(,,,,,,,,,,,,,,), + ''AssertionError, + ''VerificationConditions, + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT, + ''Identity + ] + +deriveUnifiedInterface1s + ''UnifiedSymOrd + 'withBaseSymOrd + ''UnifiedSymOrd1 + 'withBaseSymOrd1 + [ ''[], + ''Maybe, + ''Either, + ''(,), + ''ExceptT, + ''MaybeT, + ''WriterLazy.WriterT, + ''WriterStrict.WriterT, + ''Identity + ] + +-- Sum +instance + ( Typeable mode, + UnifiedSymOrd1 mode f, + UnifiedSymOrd1 mode g, + UnifiedSymOrd mode a + ) => + UnifiedSymOrd mode (Sum f g a) + where + withBaseSymOrd r = + withMode @mode + ( withBaseSymOrd1 @mode @f $ + withBaseSymOrd1 @mode @g $ + withBaseSymOrd @mode @a r + ) + ( withBaseSymOrd1 @mode @f $ + withBaseSymOrd1 @mode @g $ + withBaseSymOrd @mode @a r + ) + {-# INLINE withBaseSymOrd #-} + +instance + (Typeable mode, UnifiedSymOrd1 mode f, UnifiedSymOrd1 mode g) => + UnifiedSymOrd1 mode (Sum f g) + where + withBaseSymOrd1 r = + withMode @mode + (withBaseSymOrd1 @mode @f $ withBaseSymOrd1 @mode @g r) + (withBaseSymOrd1 @mode @f $ withBaseSymOrd1 @mode @g r) + {-# INLINE withBaseSymOrd1 #-} + +-- IdentityT +instance + (Typeable mode, UnifiedSymOrd1 mode m, UnifiedSymOrd mode a) => + UnifiedSymOrd mode (IdentityT m a) + where + withBaseSymOrd r = + withMode @mode + (withBaseSymOrd1 @mode @m $ withBaseSymOrd @mode @a r) + (withBaseSymOrd1 @mode @m $ withBaseSymOrd @mode @a r) + {-# INLINE withBaseSymOrd #-} + +instance + (Typeable mode, UnifiedSymOrd1 mode m) => + UnifiedSymOrd1 mode (IdentityT m) + where + withBaseSymOrd1 r = + withMode @mode (withBaseSymOrd1 @mode @m r) (withBaseSymOrd1 @mode @m r) + {-# INLINE withBaseSymOrd1 #-} + +instance (Typeable mode, ValidFP eb sb) => UnifiedSymOrd mode (FP eb sb) where + withBaseSymOrd r = withMode @mode r r + {-# INLINE withBaseSymOrd #-} + +instance (Typeable mode) => UnifiedSymOrd2 mode Either where + withBaseSymOrd2 r = withMode @mode r r + {-# INLINE withBaseSymOrd2 #-} + +instance (Typeable mode) => UnifiedSymOrd2 mode (,) where + withBaseSymOrd2 r = withMode @mode r r + {-# INLINE withBaseSymOrd2 #-} + +#if MIN_VERSION_base(4,16,0) +deriveUnifiedInterface1s + ''UnifiedSymOrd + 'withBaseSymOrd + ''UnifiedSymOrd1 + 'withBaseSymOrd1 + [ ''(,,), + ''(,,,) + ] + +instance (Typeable mode, UnifiedSymOrd mode a) => + UnifiedSymOrd2 mode ((,,) a) where + withBaseSymOrd2 r = + withMode @mode (withBaseSymOrd @mode @a r) (withBaseSymOrd @mode @a r) + {-# INLINE withBaseSymOrd2 #-} + +instance + (Typeable mode, UnifiedSymOrd mode a, UnifiedSymOrd mode b) => + UnifiedSymOrd2 mode ((,,,) a b) + where + withBaseSymOrd2 r = + withMode @mode + (withBaseSymOrd @mode @a $ withBaseSymOrd @mode @b r) + (withBaseSymOrd @mode @a $ withBaseSymOrd @mode @b r) + {-# INLINE withBaseSymOrd2 #-} +#endif diff --git a/src/Grisette/Unified/Internal/EvalMode.hs b/src/Grisette/Unified/Internal/EvalMode.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/EvalMode.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | +-- Module : Grisette.Unified.Internal.EvalMode +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.EvalMode (EvalMode) where + +import Data.Typeable (Typeable) +-- SafeUnifiedInteger, +-- SafeUnifiedInteger', + +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Unified.Internal.BaseMonad (BaseMonad) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) +import Grisette.Unified.Internal.UnifiedBV (AllUnifiedBV) +import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Unified.Internal.UnifiedConstraint (UnifiedPrimitive) +import Grisette.Unified.Internal.UnifiedData (AllUnifiedData) +import Grisette.Unified.Internal.UnifiedInteger + ( UnifiedInteger, + ) + +-- | A constraint that specifies that the mode is valid, and provide all the +-- corresponding constraints for the operaions for the types. +-- +-- Note for users with GHC prior to 9.2.1: the GHC compiler isn't able to +-- resolve the operations for sized bitvectors and data types. In this case, +-- you may need to provide `Grisette.Unified.Internal.UnifiedBV.UnifiedBV`, +-- `Grisette.Unified.Internal.UnifiedBV.SafeUnifiedBV`, +-- `Grisette.Unified.Internal.UnifiedBV.SafeUnifiedSomeBV`, and +-- `Grisette.Unified.Internal.UnifiedData.UnifiedData` constraints manually. +-- +-- For example, the following code is valid for GHC 9.2.1 and later: +-- +-- > fbv :: +-- > forall mode n. +-- > (EvalMode mode, KnownNat n, 1 <= n) => +-- > GetIntN mode n -> +-- > GetIntN mode n -> +-- > GetIntN mode n +-- > fbv l r = +-- > mrgIte @mode +-- > (l .== r) +-- > (l + r) +-- > (symIte @mode (l .< r) l r) +-- +-- But with older GHCs, you need to write: +-- +-- > fbv :: +-- > forall mode n. +-- > (EvalMode mode, KnownNat n, 1 <= n, UnifiedBV mode n) => +-- > GetIntN mode n -> +-- > GetIntN mode n -> +-- > GetIntN mode n +-- > fbv l r = +-- > mrgIte @mode +-- > (l .== r) +-- > (l + r) +-- > (symIte @mode (l .< r) l r) +class + ( Typeable mode, + UnifiedBool mode, + UnifiedPrimitive mode (GetBool mode), + UnifiedInteger mode, + AllUnifiedBV mode, + AllUnifiedData mode, + Monad (BaseMonad mode), + TryMerge (BaseMonad mode), + UnifiedBranching mode (BaseMonad mode) + ) => + EvalMode mode + +instance EvalMode 'Con + +instance EvalMode 'Sym diff --git a/src/Grisette/Unified/Internal/EvalModeTag.hs b/src/Grisette/Unified/Internal/EvalModeTag.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/EvalModeTag.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | +-- Module : Grisette.Unified.Internal.EvalModeTag +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.EvalModeTag + ( EvalModeTag (..), + IsConMode, + ) +where + +import Language.Haskell.TH.Syntax (Lift) + +-- | Evaluation mode for unified types. 'Con' means concrete evaluation, 'Sym' +-- means symbolic evaluation. +data EvalModeTag = Con | Sym deriving (Lift) + +-- | Type family to check if a mode is 'Con'. +type family IsConMode (mode :: EvalModeTag) = (r :: Bool) | r -> mode where + IsConMode 'Con = 'True + IsConMode 'Sym = 'False diff --git a/src/Grisette/Unified/Internal/MonadWithMode.hs b/src/Grisette/Unified/Internal/MonadWithMode.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/MonadWithMode.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Unified.Internal.MonadWithMode +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.MonadWithMode (MonadWithMode) where + +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Unified.Internal.EvalMode (EvalMode) + +-- | A constraint that specifies that the mode is valid, and provide all the +-- corresponding constraints for the operations for the types. +-- +-- This also provide the branching constraints for the monad, and the safe +-- operations: for example, 'Grisette.Unified.SafeUnifiedInteger' provides +-- 'Grisette.safeDiv' for the integer type with in @ExceptT ArithException m@. +-- +-- For users with GHC prior to 9.2.1, see notes in 'EvalMode'. +type MonadWithMode mode m = + ( EvalMode mode, + Monad m, + TryMerge m, + UnifiedBranching mode m + ) diff --git a/src/Grisette/Unified/Internal/UnifiedBV.hs b/src/Grisette/Unified/Internal/UnifiedBV.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/UnifiedBV.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | +-- Module : Grisette.Unified.Internal.UnifiedBV +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.UnifiedBV + ( GetWordN, + GetIntN, + UnifiedBV, + GetSomeWordN, + GetSomeIntN, + SafeUnifiedBV, + SafeUnifiedSomeBV, + AllUnifiedBV, + ) +where + +import Control.Exception (ArithException) +import Control.Monad.Except (MonadError) +import Data.Bits (Bits, FiniteBits) +import Data.Kind (Constraint, Type) +import GHC.TypeNats (KnownNat, Nat, type (<=)) +import Grisette.Internal.Core.Data.Class.BitVector (BV, SizedBV) +import Grisette.Internal.Core.Data.Class.SignConversion (SignConversion) +import Grisette.Internal.Core.Data.Class.SymRotate (SymRotate) +import Grisette.Internal.Core.Data.Class.SymShift (SymShift) +import Grisette.Internal.SymPrim.BV + ( BitwidthMismatch, + IntN, + WordN, + ) +import Grisette.Internal.SymPrim.SomeBV + ( SomeBV, + SomeIntN, + SomeSymIntN, + SomeSymWordN, + SomeWordN, + ) +import Grisette.Internal.SymPrim.SymBV (SymIntN, SymWordN) +import Grisette.Unified.Internal.BaseConstraint + ( BasicGrisetteType, + ConSymConversion, + ) +import Grisette.Unified.Internal.Class.UnifiedITEOp (UnifiedITEOp) +import Grisette.Unified.Internal.Class.UnifiedSafeDivision (UnifiedSafeDivision) +import Grisette.Unified.Internal.Class.UnifiedSafeLinearArith + ( UnifiedSafeLinearArith, + ) +import Grisette.Unified.Internal.Class.UnifiedSafeSymRotate + ( UnifiedSafeSymRotate, + ) +import Grisette.Unified.Internal.Class.UnifiedSafeSymShift (UnifiedSafeSymShift) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedBranching, + UnifiedSimpleMergeable, + ) +import Grisette.Unified.Internal.Class.UnifiedSymEq (UnifiedSymEq) +import Grisette.Unified.Internal.Class.UnifiedSymOrd (UnifiedSymOrd) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) + +type BVConstraint mode word int = + ( BasicGrisetteType word, + BasicGrisetteType int, + Num word, + Num int, + Bits word, + Bits int, + FiniteBits word, + FiniteBits int, + SymShift word, + SymShift int, + SymRotate word, + SymRotate int, + UnifiedSymEq mode word, + UnifiedSymEq mode int, + UnifiedSymOrd mode word, + UnifiedSymOrd mode int, + UnifiedITEOp mode word, + UnifiedITEOp mode int, + SignConversion word int + ) :: + Constraint + +type SomeBVPair mode word int = + ( BVConstraint mode word int, + BV word, + BV int, + ConSymConversion SomeWordN SomeSymWordN word, + ConSymConversion SomeIntN SomeSymIntN int + ) :: + Constraint + +class + ( BVConstraint mode (GetWordN mode n) (GetIntN mode n), + ConSymConversion (WordN n) (SymWordN n) (GetWordN mode n), + UnifiedSimpleMergeable mode (GetWordN mode n), + ConSymConversion (IntN n) (SymIntN n) (GetIntN mode n), + UnifiedSimpleMergeable mode (GetIntN mode n), + SizedBV wordn, + SizedBV intn, + wordn ~ GetWordN mode, + intn ~ GetIntN mode, + word ~ wordn n, + int ~ intn n + ) => + UnifiedBVImpl (mode :: EvalModeTag) wordn intn n word int + | wordn n -> word intn int, + word -> wordn intn n int, + intn n -> int wordn word, + int -> intn wordn n word + where + -- | Get a unified unsigned size-tagged bit vector type. Resolves to 'WordN' + -- in 'Con' mode, and 'SymWordN' in 'Sym' mode. + type GetWordN mode = (w :: Nat -> Type) | w -> mode + + -- | Get a unified signed size-tagged bit vector type. Resolves to 'IntN' + -- in 'Con' mode, and 'SymIntN' in 'Sym' mode. + type GetIntN mode = (i :: Nat -> Type) | i -> mode + +instance + (KnownNat n, 1 <= n) => + UnifiedBVImpl 'Con WordN IntN n (WordN n) (IntN n) + where + type GetWordN 'Con = WordN + type GetIntN 'Con = IntN + +instance + (KnownNat n, 1 <= n) => + UnifiedBVImpl 'Sym SymWordN SymIntN n (SymWordN n) (SymIntN n) + where + type GetWordN 'Sym = SymWordN + type GetIntN 'Sym = SymIntN + +-- | Get a unified unsigned dynamic bit width bit vector type. Resolves to +-- 'SomeWordN' in 'Con' mode, and 'SomeSymWordN' in 'Sym' mode. +type family GetSomeWordN mode = sw | sw -> mode where + GetSomeWordN mode = SomeBV (GetWordN mode) + +-- | Get a unified signed dynamic bit width bit vector type. Resolves to +-- 'SomeIntN' in 'Con' mode, and 'SomeSymIntN' in 'Sym' mode. +type family GetSomeIntN mode = sw | sw -> mode where + GetSomeIntN mode = SomeBV (GetIntN mode) + +-- | This class is needed as constraint in user code prior to GHC 9.2.1. +-- See the notes in 'Grisette.Unified.Internal.EvalMode.EvalMode'. +class + ( UnifiedBVImpl + mode + (GetWordN mode) + (GetIntN mode) + n + (GetWordN mode n) + (GetIntN mode n) + ) => + UnifiedBV mode n + +instance + ( UnifiedBVImpl + mode + (GetWordN mode) + (GetIntN mode) + n + (GetWordN mode n) + (GetIntN mode n) + ) => + UnifiedBV mode n + +class + ( UnifiedSafeDivision mode ArithException word m, + UnifiedSafeLinearArith mode ArithException word m, + UnifiedSafeSymShift mode ArithException word m, + UnifiedSafeSymRotate mode ArithException word m, + UnifiedSafeDivision mode ArithException int m, + UnifiedSafeLinearArith mode ArithException int m, + UnifiedSafeSymShift mode ArithException int m, + UnifiedSafeSymRotate mode ArithException int m, + UnifiedBVImpl mode wordn intn n word int + ) => + SafeUnifiedBVImpl (mode :: EvalModeTag) wordn intn n word int m + +instance + ( UnifiedSafeDivision mode ArithException word m, + UnifiedSafeLinearArith mode ArithException word m, + UnifiedSafeSymShift mode ArithException word m, + UnifiedSafeSymRotate mode ArithException word m, + UnifiedSafeDivision mode ArithException int m, + UnifiedSafeLinearArith mode ArithException int m, + UnifiedSafeSymShift mode ArithException int m, + UnifiedSafeSymRotate mode ArithException int m, + UnifiedBVImpl mode wordn intn n word int + ) => + SafeUnifiedBVImpl mode wordn intn n word int m + +-- | This class is needed as constraint in user code prior to GHC 9.2.1. +-- See the notes in 'Grisette.Unified.Internal.EvalMode.EvalMode'. +class + ( SafeUnifiedBVImpl + mode + (GetWordN mode) + (GetIntN mode) + n + (GetWordN mode n) + (GetIntN mode n) + m + ) => + SafeUnifiedBV mode n m + +instance + ( SafeUnifiedBVImpl + mode + (GetWordN mode) + (GetIntN mode) + n + (GetWordN mode n) + (GetIntN mode n) + m + ) => + SafeUnifiedBV mode n m + +class + ( SomeBVPair mode word int, + UnifiedSafeDivision mode (Either BitwidthMismatch ArithException) word m, + UnifiedSafeLinearArith mode (Either BitwidthMismatch ArithException) word m, + UnifiedSafeSymRotate mode (Either BitwidthMismatch ArithException) word m, + UnifiedSafeSymShift mode (Either BitwidthMismatch ArithException) word m, + UnifiedSafeDivision mode (Either BitwidthMismatch ArithException) int m, + UnifiedSafeLinearArith mode (Either BitwidthMismatch ArithException) int m, + UnifiedSafeSymRotate mode (Either BitwidthMismatch ArithException) int m, + UnifiedSafeSymShift mode (Either BitwidthMismatch ArithException) int m + ) => + SafeUnifiedSomeBVImpl (mode :: EvalModeTag) word int m + +instance + ( SomeBVPair mode word int, + UnifiedSafeDivision mode (Either BitwidthMismatch ArithException) word m, + UnifiedSafeLinearArith mode (Either BitwidthMismatch ArithException) word m, + UnifiedSafeSymRotate mode (Either BitwidthMismatch ArithException) word m, + UnifiedSafeSymShift mode (Either BitwidthMismatch ArithException) word m, + UnifiedSafeDivision mode (Either BitwidthMismatch ArithException) int m, + UnifiedSafeLinearArith mode (Either BitwidthMismatch ArithException) int m, + UnifiedSafeSymRotate mode (Either BitwidthMismatch ArithException) int m, + UnifiedSafeSymShift mode (Either BitwidthMismatch ArithException) int m + ) => + SafeUnifiedSomeBVImpl (mode :: EvalModeTag) word int m + +-- | This class is needed as constraint in user code prior to GHC 9.2.1. +-- See the notes in 'Grisette.Unified.Internal.EvalMode.EvalMode'. +class + ( SafeUnifiedSomeBVImpl + mode + (SomeBV (GetWordN mode)) + (SomeBV (GetIntN mode)) + m + ) => + SafeUnifiedSomeBV mode m + +instance + ( SafeUnifiedSomeBVImpl + mode + (SomeBV (GetWordN mode)) + (SomeBV (GetIntN mode)) + m + ) => + SafeUnifiedSomeBV mode m + +-- | Evaluation mode with unified bit vector types. +class + ( forall n m. + ( UnifiedBranching mode m, + MonadError ArithException m, + KnownNat n, + 1 <= n + ) => + SafeUnifiedBV mode n m, + forall m. + ( UnifiedBranching mode m, + MonadError (Either BitwidthMismatch ArithException) m + ) => + SafeUnifiedSomeBV mode m, + forall n. (KnownNat n, 1 <= n) => UnifiedBV mode n, + SomeBVPair mode (GetSomeWordN mode) (GetSomeIntN mode) + ) => + AllUnifiedBV mode + +instance + ( forall n m. + ( UnifiedBranching mode m, + MonadError ArithException m, + KnownNat n, + 1 <= n + ) => + SafeUnifiedBV mode n m, + forall m. + ( UnifiedBranching mode m, + MonadError (Either BitwidthMismatch ArithException) m + ) => + SafeUnifiedSomeBV mode m, + forall n. (KnownNat n, 1 <= n) => UnifiedBV mode n, + SomeBVPair mode (GetSomeWordN mode) (GetSomeIntN mode) + ) => + AllUnifiedBV mode diff --git a/src/Grisette/Unified/Internal/UnifiedBool.hs b/src/Grisette/Unified/Internal/UnifiedBool.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/UnifiedBool.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +-- | +-- Module : Grisette.Unified.Internal.UnifiedBool +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.UnifiedBool (UnifiedBool (..)) where + +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Unified.Internal.BaseConstraint + ( BasicGrisetteType, + ConSymConversion, + ) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) + +-- | Evaluation mode with unified 'Bool' type. +class + ( BasicGrisetteType (GetBool mode), + ConSymConversion Bool SymBool (GetBool mode), + LogicalOp (GetBool mode) + ) => + UnifiedBool (mode :: EvalModeTag) + where + -- | Get a unified Boolean type. Resolves to 'Bool' in 'Con' mode, and + -- 'SymBool' in 'Sym' mode. + type GetBool mode = bool | bool -> mode + +instance UnifiedBool 'Con where + type GetBool 'Con = Bool + +instance UnifiedBool 'Sym where + type GetBool 'Sym = SymBool diff --git a/src/Grisette/Unified/Internal/UnifiedConstraint.hs b/src/Grisette/Unified/Internal/UnifiedConstraint.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/UnifiedConstraint.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE MonoLocalBinds #-} + +-- | +-- Module : Grisette.Unified.Internal.UnifiedConstraint +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.UnifiedConstraint (UnifiedPrimitive) where + +import Grisette.Unified.Internal.Class.UnifiedITEOp (UnifiedITEOp) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedSimpleMergeable, + ) +import Grisette.Unified.Internal.Class.UnifiedSymEq (UnifiedSymEq) +import Grisette.Unified.Internal.Class.UnifiedSymOrd (UnifiedSymOrd) + +-- | Basic constraints for a unified primitive type. +type UnifiedPrimitive mode t = + ( UnifiedITEOp mode t, + UnifiedSymEq mode t, + UnifiedSymOrd mode t, + UnifiedSimpleMergeable mode t + ) diff --git a/src/Grisette/Unified/Internal/UnifiedData.hs b/src/Grisette/Unified/Internal/UnifiedData.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/UnifiedData.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : Grisette.Unified.Internal.UnifiedData +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.UnifiedData + ( GetData, + wrapData, + extractData, + UnifiedData, + AllUnifiedData, + ) +where + +import Control.DeepSeq (NFData) +import Data.Hashable (Hashable) +import Grisette.Internal.Core.Control.Monad.Union (Union) +import Grisette.Internal.Core.Data.Class.EvalSym (EvalSym) +import Grisette.Internal.Core.Data.Class.ExtractSym (ExtractSym) +import Grisette.Internal.Core.Data.Class.ITEOp (ITEOp) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.PPrint (PPrint) +import Grisette.Internal.Core.Data.Class.SubstSym (SubstSym) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq) +import Grisette.Internal.Core.Data.Class.SymOrd (SymOrd) +import Grisette.Internal.Core.Data.Class.ToCon (ToCon) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym) +import Grisette.Internal.Core.Data.Class.TryMerge (mrgSingle) +import Grisette.Internal.SymPrim.AllSyms (AllSyms) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable + ( UnifiedBranching (withBaseBranching), + liftBaseMonad, + ) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) +import Language.Haskell.TH.Syntax (Lift) + +class + ( u ~ GetData mode v, + Mergeable u, + (AllSyms v) => AllSyms u, + (Eq v) => Eq u, + (EvalSym v) => EvalSym u, + (ExtractSym v) => ExtractSym u, + (ITEOp v) => ITEOp u, + (PPrint v) => PPrint u, + (Hashable v) => Hashable u, + (Lift v) => Lift u, + (LogicalOp v) => LogicalOp u, + (NFData v) => NFData u, + (Num v) => Num u, + (SymEq v) => SymEq u, + (Show v) => Show u, + (SymOrd v) => SymOrd u, + (SubstSym v) => SubstSym u, + forall b. (ToCon v b) => ToCon u b, + forall a. (ToSym a v) => ToSym a u + ) => + UnifiedDataImpl (mode :: EvalModeTag) v u + | u mode -> v, + u v -> mode + where + -- | Get a unified data type. Resolves to @v@ in 'Con' mode, and @'Union' v@ + -- in 'Sym' mode. + type GetData mode v + + -- | Wraps a value into the unified data type. + wrapData :: v -> u + + -- | Extracts a value from the unified data type. + extractData :: (Monad m, UnifiedBranching mode m) => u -> m v + +instance (Mergeable v) => UnifiedDataImpl 'Con v v where + type GetData 'Con v = v + wrapData = id + extractData :: + forall m. (Mergeable v, Monad m, UnifiedBranching Con m) => v -> m v + extractData = withBaseBranching @'Con @m mrgSingle + +instance (Mergeable v) => UnifiedDataImpl 'Sym v (Union v) where + type GetData 'Sym v = Union v + wrapData = mrgSingle + extractData :: + forall m. (Mergeable v, Monad m, UnifiedBranching Sym m) => Union v -> m v + extractData = liftBaseMonad + +-- | This class is needed as constraint in user code prior to GHC 9.2.1. +-- See the notes in 'Grisette.Unified.Internal.IsMode.IsMode'. +class (UnifiedDataImpl mode v (GetData mode v)) => UnifiedData mode v + +instance (UnifiedDataImpl bool v (GetData bool v)) => UnifiedData bool v + +-- | Evaluation mode with unified data types. +class (forall v. (Mergeable v) => UnifiedData bool v) => AllUnifiedData bool + +instance (forall v. (Mergeable v) => UnifiedData bool v) => AllUnifiedData bool diff --git a/src/Grisette/Unified/Internal/UnifiedInteger.hs b/src/Grisette/Unified/Internal/UnifiedInteger.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/UnifiedInteger.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- | +-- Module : Grisette.Unified.Internal.UnifiedInteger +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.UnifiedInteger + ( GetInteger, + UnifiedInteger, + ) +where + +import Control.Exception (ArithException) +import Control.Monad.Except (MonadError) +import Grisette.Internal.SymPrim.SymInteger (SymInteger) +import Grisette.Unified.Internal.BaseConstraint + ( BasicGrisetteType, + ConSymConversion, + ) +import Grisette.Unified.Internal.Class.UnifiedSafeDivision (UnifiedSafeDivision) +import Grisette.Unified.Internal.Class.UnifiedSafeLinearArith + ( UnifiedSafeLinearArith, + ) +import Grisette.Unified.Internal.Class.UnifiedSimpleMergeable (UnifiedBranching) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) +import Grisette.Unified.Internal.UnifiedConstraint (UnifiedPrimitive) + +class + ( BasicGrisetteType (GetInteger mode), + ConSymConversion Integer SymInteger (GetInteger mode), + Num (GetInteger mode), + UnifiedPrimitive mode (GetInteger mode), + forall m. + (UnifiedBranching mode m, MonadError ArithException m) => + UnifiedSafeDivision mode ArithException i m, + forall m. + (UnifiedBranching mode m, MonadError ArithException m) => + UnifiedSafeLinearArith mode ArithException i m, + i ~ GetInteger mode + ) => + UnifiedIntegerImpl (mode :: EvalModeTag) i + | mode -> i + where + -- | Get a unified Integer type. Resolves to 'Integer' in 'Con' mode, and + -- 'SymInteger' in 'Sym' mode. + type GetInteger mode = int | int -> mode + +instance UnifiedIntegerImpl 'Con Integer where + type GetInteger 'Con = Integer + +instance UnifiedIntegerImpl 'Sym SymInteger where + type GetInteger 'Sym = SymInteger + +-- | Evaluation mode with unified 'Integer' type. +class + (UnifiedIntegerImpl mode (GetInteger mode)) => + UnifiedInteger (mode :: EvalModeTag) + +instance UnifiedInteger 'Con + +instance UnifiedInteger 'Sym diff --git a/src/Grisette/Unified/Internal/Util.hs b/src/Grisette/Unified/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Internal/Util.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | +-- Module : Grisette.Unified.Internal.Util +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Internal.Util (withMode) where + +import Data.Typeable (Typeable, eqT, type (:~:) (Refl)) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) + +-- | Case analysis on the mode. +withMode :: + forall mode r. + (Typeable mode) => + ((mode ~ 'Con) => r) -> + ((mode ~ 'Sym) => r) -> + r +withMode con sym = case (eqT @mode @'Con, eqT @mode @'Sym) of + (Just Refl, _) -> con + (_, Just Refl) -> sym + _ -> error "impossible" diff --git a/src/Grisette/Unified/Lib/Control/Applicative.hs b/src/Grisette/Unified/Lib/Control/Applicative.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Lib/Control/Applicative.hs @@ -0,0 +1,173 @@ +-- | +-- Module : Grisette.Unified.Lib.Control.Applicative +-- Copyright : (c) Sirui Lu 2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Lib.Control.Applicative + ( -- * Applicative Functors + mrgPureWithStrategy, + mrgPure, + (.<*>), + mrgLiftA2, + (.*>), + (.<*), + + -- * Alternatives + mrgEmpty, + (.<|>), + mrgSome, + mrgMany, + + -- * Utility functions + (.<$>), + (.<$), + (.<**>), + mrgLiftA, + mrgLiftA3, + mrgOptional, + mrgAsum, + ) +where + +import Control.Applicative (Alternative (empty, (<|>)), (<**>)) +import Data.Functor (void) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + MergingStrategy, + ) +import Grisette.Internal.Core.Data.Class.TryMerge + ( TryMerge, + mrgSingleWithStrategy, + tryMerge, + ) +import Grisette.Lib.Data.Functor ((.<$), (.<$>)) + +-- | Alias for 'mrgSingleWithStrategy'. +mrgPureWithStrategy :: + (TryMerge m, Applicative m) => MergingStrategy a -> a -> m a +mrgPureWithStrategy = mrgSingleWithStrategy +{-# INLINE mrgPureWithStrategy #-} + +-- | Alias for 'Grisette.Core.mrgSingle'. +mrgPure :: (TryMerge m, Applicative m, Mergeable a) => a -> m a +mrgPure = mrgPureWithStrategy rootStrategy +{-# INLINE mrgPure #-} + +infixl 4 .<*> + +-- | '<*>' with 'MergingStrategy' knowledge propagation. +(.<*>) :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => + f (a -> b) -> + f a -> + f b +f .<*> a = tryMerge $ tryMerge f <*> tryMerge a +{-# INLINE (.<*>) #-} + +-- | 'liftA2' with 'MergingStrategy' knowledge propagation. +mrgLiftA2 :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b, Mergeable c) => + (a -> b -> c) -> + f a -> + f b -> + f c +mrgLiftA2 f a b = f .<$> a .<*> tryMerge b +{-# INLINE mrgLiftA2 #-} + +infixl 4 .*> + +-- | '*>' with 'MergingStrategy' knowledge propagation. +(.*>) :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => f a -> f b -> f b +a .*> b = tryMerge $ tryMerge (void a) *> tryMerge b +{-# INLINE (.*>) #-} + +infixl 4 .<* + +-- | '<*' with 'MergingStrategy' knowledge propagation. +(.<*) :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => f a -> f b -> f a +a .<* b = tryMerge $ tryMerge a <* tryMerge (void b) +{-# INLINE (.<*) #-} + +-- | 'empty' with 'MergingStrategy' knowledge propagation. +mrgEmpty :: (Alternative f, TryMerge f, Mergeable a) => f a +mrgEmpty = tryMerge empty +{-# INLINE mrgEmpty #-} + +infixl 3 .<|> + +-- | '<|>' with 'MergingStrategy' knowledge propagation. +(.<|>) :: (Alternative f, TryMerge f, Mergeable a) => f a -> f a -> f a +a .<|> b = tryMerge $ tryMerge a <|> tryMerge b +{-# INLINE (.<|>) #-} + +-- | 'Control.Applicative.some' with 'MergingStrategy' knowledge propagation. +mrgSome :: (Alternative f, TryMerge f, Mergeable a) => f a -> f [a] +mrgSome v = some_v + where + many_v = some_v .<|> pure [] + some_v = mrgLiftA2 (:) v many_v +{-# INLINE mrgSome #-} + +-- | 'Control.Applicative.many' with 'MergingStrategy' knowledge propagation. +mrgMany :: (Alternative f, TryMerge f, Mergeable a) => f a -> f [a] +mrgMany v = many_v + where + many_v = some_v .<|> pure [] + some_v = mrgLiftA2 (:) v many_v +{-# INLINE mrgMany #-} + +infixl 4 .<**> + +-- | 'Control.Applicative.<**>' with 'MergingStrategy' knowledge propagation. +(.<**>) :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => + f a -> + f (a -> b) -> + f b +a .<**> f = tryMerge $ tryMerge a <**> tryMerge f +{-# INLINE (.<**>) #-} + +-- | 'Control.Applicative.liftA' with 'MergingStrategy' knowledge propagation. +mrgLiftA :: + (Applicative f, TryMerge f, Mergeable a, Mergeable b) => + (a -> b) -> + f a -> + f b +mrgLiftA f a = mrgPure f .<*> a +{-# INLINE mrgLiftA #-} + +-- | 'Control.Applicative.liftA3' with 'MergingStrategy' knowledge propagation. +mrgLiftA3 :: + ( Applicative f, + TryMerge f, + Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d + ) => + (a -> b -> c -> d) -> + f a -> + f b -> + f c -> + f d +mrgLiftA3 f a b c = mrgPure f .<*> a .<*> b .<*> c +{-# INLINE mrgLiftA3 #-} + +-- | 'Control.Applicative.optional' with 'MergingStrategy' knowledge propagation. +mrgOptional :: + (Alternative f, TryMerge f, Mergeable a) => + f a -> + f (Maybe a) +mrgOptional v = Just .<$> v .<|> pure Nothing +{-# INLINE mrgOptional #-} + +-- | 'Control.Applicative.asum' with 'MergingStrategy' knowledge propagation. +mrgAsum :: + (Alternative f, TryMerge f, Mergeable a, Foldable t) => t (f a) -> f a +mrgAsum = foldr (.<|>) mrgEmpty +{-# INLINE mrgAsum #-} diff --git a/src/Grisette/Unified/Lib/Control/Monad.hs b/src/Grisette/Unified/Lib/Control/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Lib/Control/Monad.hs @@ -0,0 +1,547 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.Unified.Lib.Control.Monad +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Lib.Control.Monad + ( -- * Functor and Monad classes + mrgFmap, + (.<$), + mrgReturnWithStrategy, + mrgBindWithStrategy, + mrgReturn, + (.>>=), + (.>>), + mrgFail, + mrgMzero, + mrgMplus, + + -- * Functions + + -- ** Basic 'Monad' functions + mrgMapM, + mrgMapM_, + mrgForM, + mrgForM_, + mrgSequence, + mrgSequence_, + (.=<<), + (.>=>), + (.<=<), + mrgForever, + mrgVoid, + + -- ** Generalisations of list functions + mrgJoin, + mrgMsum, + mrgMfilter, + symMfilter, + mrgFilterM, + symFilterM, + mrgMapAndUnzipM, + mrgZipWithM, + mrgZipWithM_, + mrgFoldM, + mrgFoldM_, + mrgReplicateM, + symReplicateM, + mrgReplicateM_, + symReplicateM_, + + -- ** Conditional execution of monadic expressions + mrgGuard, + symGuard, + mrgWhen, + symWhen, + mrgUnless, + symUnless, + + -- ** Monadic lifting operators + mrgLiftM, + mrgLiftM2, + mrgLiftM3, + mrgLiftM4, + mrgLiftM5, + mrgAp, + + -- ** Strict monadic functions + (.<$!>), + ) +where + +import Control.Applicative (Alternative) +import Control.Monad (MonadPlus (mplus, mzero), join) +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp (symNot, (.||))) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable (rootStrategy), + MergingStrategy, + ) +import Grisette.Internal.Core.Data.Class.SimpleMergeable (SymBranching) +import Grisette.Internal.Core.Data.Class.TryMerge + ( MonadTryMerge, + TryMerge (tryMergeWithStrategy), + tryMerge, + ) +import Grisette.Internal.SymPrim.SymBool (SymBool) +import Grisette.Lib.Data.Functor (mrgFmap, mrgUnzip, mrgVoid, (.<$)) +import Grisette.Lib.Data.Traversable + ( mrgForM, + mrgMapM, + mrgSequence, + mrgSequenceA, + mrgTraverse, + ) +import Grisette.Unified + ( GetBool, + MonadWithMode, + UnifiedSymOrd, + mrgIf, + (.<=), + ) +import Grisette.Unified.Lib.Control.Applicative + ( mrgEmpty, + mrgLiftA2, + mrgPure, + (.*>), + (.<$>), + (.<*>), + ) +import Grisette.Unified.Lib.Data.Foldable + ( mrgFoldlM, + mrgForM_, + mrgMapM_, + mrgMsum, + mrgSequenceA_, + mrgSequence_, + ) + +-- | 'return' with 'Grisette.Core.MergingStrategy' knowledge propagation. +mrgReturnWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> a -> u a +mrgReturnWithStrategy s = tryMergeWithStrategy s . return +{-# INLINE mrgReturnWithStrategy #-} + +-- | '>>=' with 'Grisette.Core.MergingStrategy' knowledge propagation. +mrgBindWithStrategy :: + (MonadTryMerge u) => + MergingStrategy a -> + MergingStrategy b -> + u a -> + (a -> u b) -> + u b +mrgBindWithStrategy sa sb a f = + tryMergeWithStrategy sb $ tryMergeWithStrategy sa a >>= f +{-# INLINE mrgBindWithStrategy #-} + +-- | 'return' with 'Grisette.Core.MergingStrategy' knowledge propagation. +mrgReturn :: (MonadTryMerge u, Mergeable a) => a -> u a +mrgReturn = mrgReturnWithStrategy rootStrategy +{-# INLINE mrgReturn #-} + +infixl 1 .>>= + +-- | '>>=' with 'Grisette.Core.MergingStrategy' knowledge propagation. +(.>>=) :: + (MonadTryMerge u, Mergeable a, Mergeable b) => + u a -> + (a -> u b) -> + u b +(.>>=) = mrgBindWithStrategy rootStrategy rootStrategy +{-# INLINE (.>>=) #-} + +infixl 1 .>> + +-- | '>>' with 'Grisette.Core.MergingStrategy' knowledge propagation. +-- +-- This is usually more efficient than calling the original '>>' and merge the +-- results. +(.>>) :: (MonadTryMerge m, Mergeable a, Mergeable b) => m a -> m b -> m b +a .>> f = tryMerge $ mrgVoid a >> f +{-# INLINE (.>>) #-} + +-- | 'fail' with 'Grisette.Core.MergingStrategy' knowledge propagation. +mrgFail :: (MonadTryMerge m, Mergeable a, MonadFail m) => String -> m a +mrgFail = tryMerge . fail +{-# INLINE mrgFail #-} + +-- | 'Control.Monad.mzero' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgMzero :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a +mrgMzero = tryMerge mzero +{-# INLINE mrgMzero #-} + +-- | 'Control.Monad.mplus' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgMplus :: + forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a -> m a -> m a +mrgMplus a b = tryMerge $ mplus (tryMerge a) (tryMerge b) +{-# INLINE mrgMplus #-} + +infixr 1 .=<< + +-- | '=<<' with 'Grisette.Core.MergingStrategy' knowledge propagation. +(.=<<) :: + (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> m b) -> m a -> m b +f .=<< a = tryMerge $ f =<< tryMerge a +{-# INLINE (.=<<) #-} + +infixr 1 .>=> + +-- | 'Control.Monad.>=>' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +(.>=>) :: + (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) => + (a -> m b) -> + (b -> m c) -> + a -> + m c +f .>=> g = \a -> tryMerge $ tryMerge (f a) >>= g +{-# INLINE (.>=>) #-} + +infixr 1 .<=< + +-- | 'Control.Monad.<=<' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +(.<=<) :: + (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) => + (b -> m c) -> + (a -> m b) -> + a -> + m c +(.<=<) = flip (.>=>) +{-# INLINE (.<=<) #-} + +-- | 'Control.Monad.forever' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgForever :: + (Applicative m, TryMerge m, Mergeable b, Mergeable a) => m a -> m b +mrgForever a = let a' = a .*> a' in a' +{-# INLINE mrgForever #-} + +-- | 'Control.Monad.join' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgJoin :: (MonadTryMerge m, Mergeable a) => m (m a) -> m a +mrgJoin a = tryMerge $ join a +{-# INLINE mrgJoin #-} + +-- | 'Control.Monad.mfilter' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgMfilter :: + (MonadTryMerge m, MonadPlus m, Mergeable a) => + (a -> Bool) -> + m a -> + m a +mrgMfilter p ma = do + a <- tryMerge ma + if p a then mrgReturn a else mrgMzero +{-# INLINE mrgMfilter #-} + +-- | 'Control.Monad.mfilter' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation and symbolic conditions. +symMfilter :: + forall mode m a. + (MonadTryMerge m, MonadPlus m, MonadWithMode mode m, Mergeable a) => + (a -> GetBool mode) -> + m a -> + m a +symMfilter p ma = do + a <- tryMerge ma + mrgIf (p a) (mrgReturn a) mrgMzero +{-# INLINE symMfilter #-} + +-- | 'Control.Monad.filterM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgFilterM :: + (TryMerge m, Applicative m, Mergeable a, Foldable t) => + (a -> m Bool) -> + t a -> + m [a] +mrgFilterM p = + foldr + (\x lst -> (\flg -> if flg then (x :) else id) .<$> p x .<*> lst) + (mrgPure []) +{-# INLINE mrgFilterM #-} + +-- | 'Control.Monad.filterM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation and symbolic conditions. +symFilterM :: + forall mode m t a. + (TryMerge m, MonadWithMode mode m, Mergeable a, Foldable t) => + (a -> m (GetBool mode)) -> + t a -> + m [a] +symFilterM p = + foldr + ( \x lst -> do + flag <- tryMerge $ p x + mrgIf flag ((x :) <$> lst) lst + ) + (mrgPure []) +{-# INLINE symFilterM #-} + +-- | 'Control.Monad.mapAndUnzipM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgMapAndUnzipM :: + ( Applicative m, + TryMerge m, + Mergeable b, + Mergeable c + ) => + (a -> m (b, c)) -> + [a] -> + m ([b], [c]) +mrgMapAndUnzipM f xs = mrgUnzip .<$> mrgTraverse f xs +{-# INLINE mrgMapAndUnzipM #-} + +-- | 'Control.Monad.zipWithM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgZipWithM :: + (Applicative m, TryMerge m, Mergeable c) => + (a -> b -> m c) -> + [a] -> + [b] -> + m [c] +mrgZipWithM f xs ys = mrgSequenceA (zipWith f xs ys) +{-# INLINE mrgZipWithM #-} + +-- | 'Control.Monad.zipWithM_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgZipWithM_ :: + (Applicative m, TryMerge m, Mergeable c) => + (a -> b -> m c) -> + [a] -> + [b] -> + m () +mrgZipWithM_ f xs ys = mrgSequenceA_ (zipWith f xs ys) +{-# INLINE mrgZipWithM_ #-} + +-- | 'Control.Monad.foldM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgFoldM :: + (MonadTryMerge m, Mergeable b, Foldable t) => + (b -> a -> m b) -> + b -> + t a -> + m b +mrgFoldM = mrgFoldlM +{-# INLINE mrgFoldM #-} + +-- | 'Control.Monad.foldM_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgFoldM_ :: + (MonadTryMerge m, Foldable t, Mergeable b) => + (b -> a -> m b) -> + b -> + t a -> + m () +mrgFoldM_ f a xs = mrgFoldlM f a xs .>> mrgPure () +{-# INLINE mrgFoldM_ #-} + +-- | 'Control.Monad.replicateM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgReplicateM :: + (Applicative m, TryMerge m, Mergeable a) => + Int -> + m a -> + m [a] +mrgReplicateM n = mrgSequenceA . replicate n +{-# INLINE mrgReplicateM #-} + +-- | 'Control.Monad.replicateM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation and symbolic number of elements. +symReplicateM :: + forall mode m a int. + ( MonadWithMode mode m, + TryMerge m, + Mergeable a, + Num int, + UnifiedSymOrd mode Int, + UnifiedSymOrd mode int + ) => + Int -> + int -> + m a -> + m [a] +symReplicateM maxCnt cnt0 f = + loop maxCnt cnt0 + where + loop concreteCnt cnt = + mrgIf @mode + (cnt .<= 0 .|| concreteCnt .<= 0) + (mrgPure []) + (mrgLiftA2 (:) f (loop (concreteCnt - 1) (cnt - 1))) +{-# INLINE symReplicateM #-} + +-- | 'Control.Monad.replicateM_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgReplicateM_ :: + (Applicative m, TryMerge m, Mergeable a) => + Int -> + m a -> + m () +mrgReplicateM_ n = mrgSequenceA_ . replicate n +{-# INLINE mrgReplicateM_ #-} + +-- | 'Control.Monad.replicateM_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation and symbolic number of elements. +symReplicateM_ :: + forall mode m a int. + ( MonadWithMode mode m, + TryMerge m, + Mergeable a, + Num int, + UnifiedSymOrd mode Int, + UnifiedSymOrd mode int + ) => + Int -> + int -> + m a -> + m () +symReplicateM_ maxCnt cnt0 f = + loop maxCnt cnt0 + where + loop concreteCnt cnt = + mrgIf @mode + (cnt .<= 0 .|| concreteCnt .<= 0) + (mrgPure ()) + (f .*> (loop (concreteCnt - 1) (cnt - 1))) +{-# INLINE symReplicateM_ #-} + +-- | 'Control.Monad.guard' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgGuard :: (Alternative m, TryMerge m) => Bool -> m () +mrgGuard True = mrgPure () +mrgGuard False = mrgEmpty +{-# INLINE mrgGuard #-} + +-- | 'Control.Monad.guard' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation and symbolic conditions. +symGuard :: (SymBranching m, TryMerge m, Alternative m) => SymBool -> m () +symGuard b = mrgIf b (mrgPure ()) mrgEmpty +{-# INLINE symGuard #-} + +-- | 'Control.Monad.when' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgWhen :: (Applicative m, TryMerge m) => Bool -> m () -> m () +mrgWhen True a = tryMerge a +mrgWhen False _ = mrgPure () +{-# INLINE mrgWhen #-} + +-- | 'Control.Monad.when' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation and symbolic conditions. +symWhen :: + (Applicative m, TryMerge m, SymBranching m) => SymBool -> m () -> m () +symWhen b a = mrgIf b a (mrgPure ()) +{-# INLINE symWhen #-} + +-- | 'Control.Monad.unless' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgUnless :: (Applicative m, TryMerge m) => Bool -> m () -> m () +mrgUnless b = mrgWhen (not b) +{-# INLINE mrgUnless #-} + +-- | 'Control.Monad.unless' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation and symbolic conditions. +symUnless :: + (Applicative m, TryMerge m, SymBranching m) => SymBool -> m () -> m () +symUnless b = symWhen (symNot b) +{-# INLINE symUnless #-} + +-- | 'Control.Monad.liftM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgLiftM :: + (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> b) -> m a -> m b +mrgLiftM f a = f .<$> a +{-# INLINE mrgLiftM #-} + +-- | 'Control.Monad.liftM2' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgLiftM2 :: + (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c) => + (a -> b -> c) -> + m a -> + m b -> + m c +mrgLiftM2 f a b = f .<$> a .<*> b +{-# INLINE mrgLiftM2 #-} + +-- | 'Control.Monad.liftM3' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgLiftM3 :: + (MonadTryMerge m, Mergeable a, Mergeable b, Mergeable c, Mergeable d) => + (a -> b -> c -> d) -> + m a -> + m b -> + m c -> + m d +mrgLiftM3 f a b c = f .<$> a .<*> b .<*> c +{-# INLINE mrgLiftM3 #-} + +-- | 'Control.Monad.liftM4' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgLiftM4 :: + ( MonadTryMerge m, + Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e + ) => + (a -> b -> c -> d -> e) -> + m a -> + m b -> + m c -> + m d -> + m e +mrgLiftM4 f a b c d = f .<$> a .<*> b .<*> c .<*> d +{-# INLINE mrgLiftM4 #-} + +-- | 'Control.Monad.liftM5' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgLiftM5 :: + ( MonadTryMerge m, + Mergeable a, + Mergeable b, + Mergeable c, + Mergeable d, + Mergeable e, + Mergeable f + ) => + (a -> b -> c -> d -> e -> f) -> + m a -> + m b -> + m c -> + m d -> + m e -> + m f +mrgLiftM5 f a b c d e = f .<$> a .<*> b .<*> c .<*> d .<*> e +{-# INLINE mrgLiftM5 #-} + +-- | 'Control.Monad.<*>' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgAp :: + (MonadTryMerge m, Mergeable a, Mergeable b) => m (a -> b) -> m a -> m b +mrgAp = (.<*>) +{-# INLINE mrgAp #-} + +infixl 4 .<$!> + +-- | 'Control.Monad.<$!>' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. Merging is always strict so we can directly use +-- 'Grisette.Unified.Lib.Data.Functor..<$>'. +(.<$!>) :: + (MonadTryMerge m, Mergeable a, Mergeable b) => (a -> b) -> m a -> m b +f .<$!> a = f .<$> a +{-# INLINE (.<$!>) #-} diff --git a/src/Grisette/Unified/Lib/Control/Monad.hs-boot b/src/Grisette/Unified/Lib/Control/Monad.hs-boot new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Lib/Control/Monad.hs-boot @@ -0,0 +1,30 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE Trustworthy #-} + +module Grisette.Unified.Lib.Control.Monad + ( mrgReturnWithStrategy, + mrgBindWithStrategy, + mrgReturn, + (.>>=), + mrgFoldM, + (.>>), + mrgMzero, + mrgMplus, + ) +where + +import Control.Monad (MonadPlus) +import Grisette.Internal.Core.Data.Class.Mergeable + ( Mergeable, + MergingStrategy, + ) +import Grisette.Internal.Core.Data.Class.TryMerge (MonadTryMerge) + +mrgReturnWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> a -> u a +mrgBindWithStrategy :: (MonadTryMerge u) => MergingStrategy a -> MergingStrategy b -> u a -> (a -> u b) -> u b +mrgReturn :: (MonadTryMerge u, Mergeable a) => a -> u a +(.>>=) :: (MonadTryMerge u, Mergeable a, Mergeable b) => u a -> (a -> u b) -> u b +mrgFoldM :: (MonadTryMerge m, Mergeable b, Foldable t) => (b -> a -> m b) -> b -> t a -> m b +(.>>) :: (MonadTryMerge m, Mergeable a, Mergeable b) => m a -> m b -> m b +mrgMzero :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a +mrgMplus :: forall m a. (MonadTryMerge m, Mergeable a, MonadPlus m) => m a -> m a -> m a diff --git a/src/Grisette/Unified/Lib/Data/Foldable.hs b/src/Grisette/Unified/Lib/Data/Foldable.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Lib/Data/Foldable.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MonoLocalBinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- | +-- Module : Grisette.Unified.Lib.Data.Foldable +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Lib.Data.Foldable + ( symElem, + symMaximum, + mrgMaximum, + symMinimum, + mrgMinimum, + + -- * Special biased folds + mrgFoldrM, + mrgFoldlM, + + -- * Folding actions + + -- ** Applicative actions + mrgTraverse_, + mrgFor_, + mrgSequenceA_, + mrgAsum, + + -- ** Monadic actions + mrgMapM_, + mrgForM_, + mrgSequence_, + mrgMsum, + + -- * Folding actions + symAnd, + symOr, + symAny, + symAll, + symMaximumBy, + mrgMaximumBy, + symMinimumBy, + mrgMinimumBy, + + -- ** Searches + symNotElem, + mrgFind, + ) +where + +import Control.Monad (MonadPlus) +import Data.Foldable (Foldable (foldl')) +import Grisette.Internal.Core.Data.Class.LogicalOp + ( LogicalOp (symNot, (.&&), (.||)), + ) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.ToSym (ToSym (toSym)) +import Grisette.Internal.Core.Data.Class.TryMerge + ( MonadTryMerge, + TryMerge, + mrgSingle, + tryMerge, + ) +import Grisette.Unified + ( MonadWithMode, + UnifiedITEOp, + UnifiedSymOrd, + liftBaseMonad, + mrgIf, + symIteMerge, + ) +import Grisette.Unified.Internal.BaseMonad (BaseMonad) +import Grisette.Unified.Internal.Class.UnifiedSymEq (UnifiedSymEq, (.==)) +import Grisette.Unified.Internal.Class.UnifiedSymOrd (mrgMax, mrgMin) +import Grisette.Unified.Internal.EvalMode (EvalMode) +import Grisette.Unified.Internal.UnifiedBool (GetBool) +import Grisette.Unified.Lib.Control.Applicative (mrgAsum, mrgPure, (.*>)) +import {-# SOURCE #-} Grisette.Unified.Lib.Control.Monad + ( mrgMplus, + mrgMzero, + (.>>), + ) +import Grisette.Unified.Lib.Data.Functor (mrgFmap, mrgVoid) + +-- | 'Data.Foldable.elem' with symbolic equality. +symElem :: + forall mode t a. + (Foldable t, EvalMode mode, UnifiedSymEq mode a) => + a -> + t a -> + GetBool mode +symElem x = symAny ((.== x)) +{-# INLINE symElem #-} + +-- | 'Data.Foldable.maximum' with unified comparison. +mrgMaximum :: + forall mode a t m. + (Foldable t, MonadWithMode mode m, Mergeable a, UnifiedSymOrd mode a) => + t a -> + m a +mrgMaximum l = do + r <- mrgFoldlM symMax' (Nothing :: Maybe a) l + case r of + Nothing -> errorWithoutStackTrace "mrgMaximum: empty structure" + Just x -> mrgPure x + where + symMax' :: Maybe a -> a -> m (Maybe a) + symMax' mx y = + case mx of + Nothing -> mrgPure $ Just y + Just x -> mrgFmap Just $ mrgMax @mode x y +{-# INLINE mrgMaximum #-} + +-- | 'Data.Foldable.maximum' with result merged with 'Grisette.Core.ITEOp'. +symMaximum :: + forall mode a t. + ( Foldable t, + Mergeable a, + UnifiedSymOrd mode a, + UnifiedITEOp mode a, + EvalMode mode + ) => + t a -> + a +symMaximum l = symIteMerge (mrgMaximum @mode l :: BaseMonad mode a) +{-# INLINE symMaximum #-} + +-- | 'Data.Foldable.minimum' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgMinimum :: + forall mode a t m. + (Foldable t, MonadWithMode mode m, Mergeable a, UnifiedSymOrd mode a) => + t a -> + m a +mrgMinimum l = do + r <- mrgFoldlM symMin' (Nothing :: Maybe a) l + case r of + Nothing -> errorWithoutStackTrace "mrgMinimum: empty structure" + Just x -> mrgPure x + where + symMin' :: Maybe a -> a -> m (Maybe a) + symMin' mx y = + case mx of + Nothing -> mrgPure $ Just y + Just x -> mrgFmap Just $ mrgMin @mode x y + +-- | 'Data.Foldable.maximum' with result merged with 'Grisette.Core.ITEOp'. +symMinimum :: + forall mode a t. + ( Foldable t, + Mergeable a, + UnifiedSymOrd mode a, + UnifiedITEOp mode a, + EvalMode mode + ) => + t a -> + a +symMinimum l = symIteMerge (mrgMinimum @mode l :: BaseMonad mode a) +{-# INLINE symMinimum #-} + +-- | 'Data.Foldable.foldrM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgFoldrM :: + (MonadTryMerge m, Mergeable b, Foldable t) => + (a -> b -> m b) -> + b -> + t a -> + m b +mrgFoldrM f z0 xs = foldl c mrgPure xs z0 + where + c k x z = tryMerge (f x z) >>= k +{-# INLINE mrgFoldrM #-} + +-- | 'Data.Foldable.foldlM' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgFoldlM :: + (MonadTryMerge m, Mergeable b, Foldable t) => + (b -> a -> m b) -> + b -> + t a -> + m b +mrgFoldlM f z0 xs = foldr c mrgPure xs z0 + where + c x k z = tryMerge (f z x) >>= k +{-# INLINE mrgFoldlM #-} + +-- | 'Data.Foldable.traverse_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgTraverse_ :: + (Applicative m, TryMerge m, Foldable t) => (a -> m b) -> t a -> m () +mrgTraverse_ f = foldr c (mrgPure ()) + where + c x k = mrgVoid (f x) .*> k +{-# INLINE mrgTraverse_ #-} + +-- | 'Data.Foldable.for_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgFor_ :: + (Applicative m, TryMerge m, Foldable t) => t a -> (a -> m b) -> m () +mrgFor_ = flip mrgTraverse_ +{-# INLINE mrgFor_ #-} + +-- | 'Data.Foldable.sequence_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgSequenceA_ :: + (Foldable t, TryMerge m, Applicative m) => t (m a) -> m () +mrgSequenceA_ = foldr c (mrgPure ()) + where + c m k = mrgVoid m .*> k +{-# INLINE mrgSequenceA_ #-} + +-- | 'Data.Foldable.mapM_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgMapM_ :: (MonadTryMerge m, Foldable t) => (a -> m b) -> t a -> m () +mrgMapM_ = mrgTraverse_ +{-# INLINE mrgMapM_ #-} + +-- | 'Data.Foldable.forM_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgForM_ :: (MonadTryMerge m, Foldable t) => t a -> (a -> m b) -> m () +mrgForM_ = flip mrgMapM_ +{-# INLINE mrgForM_ #-} + +-- | 'Data.Foldable.sequence_' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgSequence_ :: (Foldable t, MonadTryMerge m) => t (m a) -> m () +mrgSequence_ = foldr c (mrgPure ()) + where + c m k = mrgVoid m .>> k +{-# INLINE mrgSequence_ #-} + +-- | 'Data.Foldable.msum' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgMsum :: + (MonadTryMerge m, Mergeable a, MonadPlus m, Foldable t) => t (m a) -> m a +mrgMsum = foldr mrgMplus mrgMzero +{-# INLINE mrgMsum #-} + +-- | 'Data.Foldable.and' on unified boolean. +symAnd :: (EvalMode mode, Foldable t) => t (GetBool mode) -> GetBool mode +symAnd = foldl' (.&&) (toSym True) +{-# INLINE symAnd #-} + +-- | 'Data.Foldable.or' on unified boolean. +symOr :: (EvalMode mode, Foldable t) => t (GetBool mode) -> GetBool mode +symOr = foldl' (.||) (toSym False) +{-# INLINE symOr #-} + +-- | 'Data.Foldable.any' on unified boolean. +symAny :: + (EvalMode mode, Foldable t) => (a -> GetBool mode) -> t a -> GetBool mode +symAny f = foldl' (\acc v -> acc .|| f v) (toSym False) +{-# INLINE symAny #-} + +-- | 'Data.Foldable.all' on unified boolean. +symAll :: + (EvalMode mode, Foldable t) => (a -> GetBool mode) -> t a -> GetBool mode +symAll f = foldl' (\acc v -> acc .&& f v) (toSym True) +{-# INLINE symAll #-} + +-- | 'Data.Foldable.maximumBy' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgMaximumBy :: + forall mode t a m. + (Foldable t, Mergeable a, MonadWithMode mode m) => + (a -> a -> BaseMonad mode Ordering) -> + t a -> + m a +mrgMaximumBy cmp l = do + r <- mrgFoldlM symMax' (Nothing :: Maybe a) l + case r of + Nothing -> errorWithoutStackTrace "mrgMaximumBy: empty structure" + Just x -> mrgSingle x + where + symMax' :: Maybe a -> a -> m (Maybe a) + symMax' mx y = + case mx of + Nothing -> mrgSingle $ Just y + Just x -> do + cmpRes <- liftBaseMonad $ cmp x y + case cmpRes of + GT -> mrgSingle $ Just x + _ -> mrgSingle $ Just y + +-- | 'Data.Foldable.maximumBy' with result merged with 'Grisette.Core.ITEOp'. +symMaximumBy :: + forall mode t a. + (Foldable t, Mergeable a, UnifiedITEOp mode a, EvalMode mode) => + (a -> a -> BaseMonad mode Ordering) -> + t a -> + a +symMaximumBy cmp l = symIteMerge (mrgMaximumBy cmp l :: BaseMonad mode a) +{-# INLINE symMaximumBy #-} + +-- | 'Data.Foldable.minimumBy' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +mrgMinimumBy :: + forall mode t a m. + (Foldable t, Mergeable a, MonadWithMode mode m) => + (a -> a -> BaseMonad mode Ordering) -> + t a -> + m a +mrgMinimumBy cmp l = do + r <- mrgFoldlM symMin' (Nothing :: Maybe a) l + case r of + Nothing -> errorWithoutStackTrace "mrgMinimumBy: empty structure" + Just x -> mrgSingle x + where + symMin' :: Maybe a -> a -> m (Maybe a) + symMin' mx y = + case mx of + Nothing -> mrgSingle $ Just y + Just x -> do + cmpRes <- liftBaseMonad $ cmp x y + case cmpRes of + GT -> mrgSingle $ Just y + _ -> mrgSingle $ Just x + +-- | 'Data.Foldable.minimumBy' with result merged with 'Grisette.Core.ITEOp'. +symMinimumBy :: + forall mode t a. + (Foldable t, Mergeable a, UnifiedITEOp mode a, EvalMode mode) => + (a -> a -> BaseMonad mode Ordering) -> + t a -> + a +symMinimumBy cmp l = symIteMerge (mrgMinimumBy cmp l :: BaseMonad mode a) +{-# INLINE symMinimumBy #-} + +-- | 'Data.Foldable.elem' with symbolic equality. +symNotElem :: + (Foldable t, UnifiedSymEq mode a, EvalMode mode) => + a -> + t a -> + GetBool mode +symNotElem x = symNot . symElem x +{-# INLINE symNotElem #-} + +-- | 'Data.Foldable.elem' with symbolic equality and +-- 'Grisette.Core.MergingStrategy' knowledge propagation. +mrgFind :: + (Foldable t, MonadWithMode mode m, Mergeable a) => + (a -> GetBool mode) -> + t a -> + m (Maybe a) +mrgFind f = mrgFoldlM fst (Nothing :: Maybe a) + where + fst acc v = do + case acc of + Just _ -> mrgPure acc + Nothing -> do + mrgIf (f v) (mrgPure $ Just v) (mrgPure Nothing) diff --git a/src/Grisette/Unified/Lib/Data/Functor.hs b/src/Grisette/Unified/Lib/Data/Functor.hs new file mode 100644 --- /dev/null +++ b/src/Grisette/Unified/Lib/Data/Functor.hs @@ -0,0 +1,81 @@ +-- | +-- Module : Grisette.Unified.Lib.Control.Functor +-- Copyright : (c) Sirui Lu 2021-2024 +-- License : BSD-3-Clause (see the LICENSE file) +-- +-- Maintainer : siruilu@cs.washington.edu +-- Stability : Experimental +-- Portability : GHC only +module Grisette.Unified.Lib.Data.Functor + ( mrgFmap, + (.<$), + (.$>), + (.<$>), + (.<&>), + mrgUnzip, + mrgVoid, + ) +where + +import Control.Monad (void) +import Grisette.Internal.Core.Data.Class.Mergeable (Mergeable) +import Grisette.Internal.Core.Data.Class.TryMerge (TryMerge, tryMerge) + +-- | 'fmap' with 'Grisette.Core.MergingStrategy' knowledge propagation. +mrgFmap :: + (TryMerge f, Mergeable a, Mergeable b, Functor f) => + (a -> b) -> + f a -> + f b +mrgFmap f a = tryMerge $ fmap f (tryMerge a) +{-# INLINE mrgFmap #-} + +infixl 4 .<$> + +-- | '<$>' with 'Grisette.Core.MergingStrategy' knowledge propagation. +(.<$>) :: + (TryMerge f, Mergeable a, Mergeable b, Functor f) => (a -> b) -> f a -> f b +(.<$>) = mrgFmap +{-# INLINE (.<$>) #-} + +infixl 4 .<$ + +-- | '<$' with 'Grisette.Core.MergingStrategy' knowledge propagation. +(.<$) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => b -> f a -> f b +(.<$) v f = tryMerge $ v <$ tryMerge f +{-# INLINE (.<$) #-} + +infixl 4 .$> + +-- | 'Data.Functor.$>' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +(.$>) :: (TryMerge f, Mergeable a, Mergeable b, Functor f) => f a -> b -> f b +(.$>) = flip (.<$) +{-# INLINE (.$>) #-} + +infixl 1 .<&> + +-- | 'Data.Functor.<&>' with 'Grisette.Core.MergingStrategy' knowledge +-- propagation. +(.<&>) :: + (TryMerge f, Mergeable a, Mergeable b, Functor f) => + f a -> + (a -> b) -> + f b +(.<&>) = flip mrgFmap +{-# INLINE (.<&>) #-} + +-- | 'unzip' with 'Grisette.Core.MergingStrategy' knowledge propagation. +mrgUnzip :: + (TryMerge f, Mergeable a, Mergeable b, Functor f) => + f (a, b) -> + (f a, f b) +mrgUnzip ab = + let mergedAb = tryMerge ab + in (fst .<$> mergedAb, snd .<$> mergedAb) +{-# INLINE mrgUnzip #-} + +-- | 'void' with 'Grisette.Core.MergingStrategy' knowledge propagation. +mrgVoid :: (TryMerge f, Functor f) => f a -> f () +mrgVoid x = tryMerge $ void x +{-# INLINE mrgVoid #-} diff --git a/src/Grisette/Utils.hs b/src/Grisette/Utils.hs --- a/src/Grisette/Utils.hs +++ b/src/Grisette/Utils.hs @@ -1,6 +1,39 @@ -- Disable this warning because we are re-exporting things. {-# OPTIONS_GHC -Wno-missing-import-lists #-} +-- This file contains code from the parameterized-utils package: +-- +-- Copyright (c) 2013-2022 Galois Inc. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- * Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- * Neither the name of Galois, Inc. nor the names of its contributors +-- may be used to endorse or promote products derived from this +-- software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + -- | -- Module : Grisette.Utils -- Copyright : (c) Sirui Lu 2021-2023 diff --git a/test/Grisette/Backend/CEGISTests.hs b/test/Grisette/Backend/CEGISTests.hs --- a/test/Grisette/Backend/CEGISTests.hs +++ b/test/Grisette/Backend/CEGISTests.hs @@ -10,25 +10,24 @@ import Control.Monad.Except (ExceptT) import Data.Proxy (Proxy (Proxy)) -import qualified Data.SBV as SBV import Data.String (IsString (fromString)) import GHC.Stack (HasCallStack) import Grisette ( Apply (apply), CEGISResult (CEGISSolverFailure, CEGISSuccess, CEGISVerifierFailure), - EvaluateSym (evaluateSym), - ExtractSymbolics, + EvalSym (evalSym), + ExtractSym, Function ((#)), GrisetteSMTConfig, ITEOp (symIte), LogicalOp (symNot, symXor, (.&&), (.||)), ModelRep (buildModel), ModelValuePair ((::=)), - SEq ((.==)), - SOrd ((.<), (.>=)), SizedBV (sizedBVConcat, sizedBVSelect, sizedBVSext, sizedBVZext), Solvable (con), - UnionM, + SymEq ((.==)), + SymOrd ((.<), (.>=)), + Union, VerificationConditions, cegis, cegisExceptVC, @@ -37,7 +36,6 @@ cegisMultiInputs, cegisPostCond, mrgIf, - precise, solve, symAssert, symAssume, @@ -55,7 +53,7 @@ import Test.HUnit (Assertion, assertFailure, (@=?), (@?=)) testCegis :: - (HasCallStack, ExtractSymbolics a, EvaluateSym a, Show a, SEq a) => + (HasCallStack, ExtractSym a, EvalSym a, Show a, SymEq a) => GrisetteSMTConfig i -> Bool -> a -> @@ -81,7 +79,7 @@ where verify _ _ [] = return () verify funName m (v : vs) = do - y <- solve config (evaluateSym False m $ symNot v) + y <- solve config (evalSym False m $ symNot v) case y of Left _ -> verify funName m vs Right _ -> @@ -96,7 +94,7 @@ go l 0 where go :: - [SymBool] -> SymInteger -> ExceptT VerificationConditions UnionM () + [SymBool] -> SymInteger -> ExceptT VerificationConditions Union () go [] _ = return () go (x : xs) i = mrgIf @@ -106,7 +104,7 @@ cegisTests :: Test cegisTests = - let unboundedConfig = precise SBV.z3 + let unboundedConfig = z3 in testGroup "CEGIS" [ testGroup @@ -114,10 +112,10 @@ [ testCase "Empty symbolic inputs makes cegis work like solve" $ do (_, CEGISSuccess m1) <- cegisMultiInputs - (precise z3) + z3 [1 :: Integer, 2] (\idx -> cegisPostCond $ fromString $ "a" ++ show idx) - Right m2 <- solve (precise z3) ("a1" .&& "a2") + Right m2 <- solve z3 ("a1" .&& "a2") m1 @=? m2, testCase "Lowering of TabularFun" $ do let s1 = "s1" :: SymInteger =~> SymInteger @@ -129,9 +127,9 @@ apply (symIte cond s1 s2) (symIte cond 1 2) .== 10 .&& apply (symIte cond s1 s2) (symIte cond 3 4) - .== 100 - let s1e = evaluateSym False m1 s1 - let s2e = evaluateSym False m1 s2 + .== 100 + let s1e = evalSym False m1 s1 + let s2e = evalSym False m1 s2 s1e # 1 @=? 10 s1e # 3 @=? 100 s2e # 2 @=? 10 @@ -146,9 +144,9 @@ apply (symIte cond s1 s2) (symIte cond 1 2) .== 10 .&& apply (symIte cond s1 s2) (symIte cond 3 4) - .== 100 - let s1e = evaluateSym False m1 s1 - let s2e = evaluateSym False m1 s2 + .== 100 + let s1e = evalSym False m1 s1 + let s2e = evalSym False m1 s2 s1e # 1 @=? 10 s1e # 3 @=? 100 s2e # 2 @=? 10 diff --git a/test/Grisette/Backend/LoweringTests.hs b/test/Grisette/Backend/LoweringTests.hs --- a/test/Grisette/Backend/LoweringTests.hs +++ b/test/Grisette/Backend/LoweringTests.hs @@ -22,12 +22,12 @@ import qualified Data.Text as T import GHC.Stack (HasCallStack) import Grisette - ( EvaluateSym (evaluateSym), + ( EvalSym (evalSym), Function ((#)), IntN, LogicalOp ((.&&)), - SEq ((.==)), Solvable (con), + SymEq ((.==)), SymInteger, WordN, solve, @@ -36,10 +36,10 @@ ) import Grisette.Internal.Backend.Solving ( GrisetteSMTConfig (sbvConfig), - approx, + approximate, lowerSinglePrim, lowerSinglePrimCached, - precise, + z3, ) import Grisette.Internal.Backend.SymBiMap ( SymBiMap (biMapToSBV), @@ -49,7 +49,20 @@ ( SomeTerm (SomeTerm), ) import Grisette.Internal.SymPrim.Prim.Term - ( FPTrait (FPIsInfinite, FPIsNaN, FPIsNegative, FPIsNegativeInfinite, FPIsNegativeZero, FPIsNormal, FPIsPoint, FPIsPositive, FPIsPositiveInfinite, FPIsPositiveZero, FPIsSubnormal, FPIsZero), + ( FPTrait + ( FPIsInfinite, + FPIsNaN, + FPIsNegative, + FPIsNegativeInfinite, + FPIsNegativeZero, + FPIsNormal, + FPIsPoint, + FPIsPositive, + FPIsPositiveInfinite, + FPIsPositiveZero, + FPIsSubnormal, + FPIsZero + ), SBVRep (SBVType), SupportedPrim, Term, @@ -260,8 +273,8 @@ loweringTests :: Test loweringTests = - let unboundedConfig = precise SBV.z3 - boundedConfig = approx (Proxy @5) SBV.z3 + let unboundedConfig = z3 + boundedConfig = approximate (Proxy @5) z3 in testGroup "Lowering" [ testGroup @@ -818,9 +831,9 @@ (f # a # b .== a + b .&& a .== 10 .&& b .== 20) .&& (f # a # c .== a + c .&& a .== 10 .&& c .== 30) .&& (f # a # d .== a + d .&& a .== 10 .&& d .== 40) - evaluateSym False m (f # a # b .== a + b) @?= con True - evaluateSym False m (f # a # c .== a + c) @?= con True - evaluateSym False m (f # a # d .== a + d) @?= con True, + evalSym False m (f # a # b .== a + b) @?= con True + evalSym False m (f # a # c .== a + c) @?= con True + evalSym False m (f # a # d .== a + d) @?= con True, testCase "GeneralFun" $ do let f = "f" :: SymInteger -~> SymInteger -~> SymInteger let a = "a" :: SymInteger @@ -832,7 +845,7 @@ (f # a # b .== a + b .&& a .== 10 .&& b .== 20) .&& (f # a # c .== a + c .&& a .== 10 .&& c .== 30) .&& (f # a # d .== a + d .&& a .== 10 .&& d .== 40) - evaluateSym False m (f # a # b .== a + b) @?= con True - evaluateSym False m (f # a # c .== a + c) @?= con True - evaluateSym False m (f # a # d .== a + d) @?= con True + evalSym False m (f # a # b .== a + b) @?= con True + evalSym False m (f # a # c .== a + c) @?= con True + evalSym False m (f # a # d .== a + d) @?= con True ] diff --git a/test/Grisette/Backend/TermRewritingTests.hs b/test/Grisette/Backend/TermRewritingTests.hs --- a/test/Grisette/Backend/TermRewritingTests.hs +++ b/test/Grisette/Backend/TermRewritingTests.hs @@ -14,10 +14,6 @@ where import Data.Foldable (traverse_) -#if MIN_VERSION_sbv(8,17,0) -import Data.SBV (bitwuzla) -#endif -import qualified Data.SBV as SBV import Grisette ( GrisetteSMTConfig, ITEOp (symIte), @@ -26,8 +22,9 @@ Solvable (con), SymBool (SymBool), WordN, - precise, + bitwuzla, solve, + z3, ) import Grisette.Backend.TermRewritingGen ( BoolOnlySpec, @@ -70,7 +67,7 @@ SymIEEEFPTraits (symFpIsPositiveInfinite), ) import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) -import Grisette.Internal.Core.Data.Class.SEq (SEq ((./=), (.==))) +import Grisette.Internal.Core.Data.Class.SymEq (SymEq ((./=), (.==))) import Grisette.Internal.SymPrim.FP (FP32) import Grisette.Internal.SymPrim.Prim.Term ( FPTrait (FPIsPositive), @@ -105,19 +102,19 @@ bitwuzlaConfig :: IO (Maybe (GrisetteSMTConfig 0)) bitwuzlaConfig = do -#if MIN_VERSION_sbv(8,17,0) - v <- solve (precise bitwuzla) $ - ("x" :: SymFP32) ./= "x" .&& - symNot (symFpIsPositiveInfinite (con $ -4.7e-38 :: SymFP32)) .&& - (symIte "bool" - (con $ fpPositiveInfinite :: SymFP32) - (con $ fpNegativeInfinite) .== "m") + v <- + solve bitwuzla $ + (("x" :: SymFP32) ./= "x") + .&& symNot (symFpIsPositiveInfinite (con $ -4.7e-38 :: SymFP32)) + .&& ( symIte + "bool" + (con fpPositiveInfinite :: SymFP32) + (con fpNegativeInfinite) + .== "m" + ) case v of Left _ -> return Nothing - Right _ -> return $ Just $ precise bitwuzla -#else - return Nothing -#endif + Right _ -> return $ Just bitwuzla onlyWhenBitwuzlaIsAvailable :: (GrisetteSMTConfig 0 -> IO ()) -> IO () onlyWhenBitwuzlaIsAvailable action = do @@ -130,7 +127,7 @@ <> " library does not work well with it. This test is marked as " <> " success." -unboundedConfig = precise SBV.z3 +unboundedConfig = z3 divisionTest :: forall a b. diff --git a/test/Grisette/Core/Control/ExceptionTests.hs b/test/Grisette/Core/Control/ExceptionTests.hs --- a/test/Grisette/Core/Control/ExceptionTests.hs +++ b/test/Grisette/Core/Control/ExceptionTests.hs @@ -9,21 +9,21 @@ import Control.Monad.Except (ExceptT (ExceptT)) import Grisette ( AssertionError (AssertionError), - EvaluateSym (evaluateSym), - ExtractSymbolics (extractSymbolics), + EvalSym (evalSym), + ExtractSym (extractSym), LogicalOp (symNot), Mergeable (rootStrategy), MergingStrategy (SimpleStrategy), ModelOps (emptyModel), - SEq ((.==)), - SOrd (symCompare, (.<), (.<=), (.>), (.>=)), SimpleMergeable (mrgIte), Solvable (con), + SymEq ((.==)), + SymOrd (symCompare, (.<), (.<=), (.>), (.>=)), SymbolSetOps (emptySet), ToCon (toCon), ToSym (toSym), TransformError (transformError), - UnionM, + Union, VerificationConditions (AssertionViolation, AssumptionViolation), mrgIf, mrgSingle, @@ -43,20 +43,20 @@ toCon AssertionError @?= Just AssertionError, testCase "ToSym" $ do toSym AssertionError @?= AssertionError, - testCase "SEq" $ do + testCase "SymEq" $ do AssertionError .== AssertionError @?= con True, - testCase "SOrd" $ do + testCase "SymOrd" $ do AssertionError .<= AssertionError @?= con True AssertionError .< AssertionError @?= con False AssertionError .>= AssertionError @?= con True AssertionError .> AssertionError @?= con False AssertionError `symCompare` AssertionError - @?= (mrgSingle EQ :: UnionM Ordering), - testCase "GEvaluateSym" $ do - evaluateSym False emptyModel AssertionError @?= AssertionError, - testCase "GExtractSymbolics" $ do - extractSymbolics AssertionError @?= emptySet, + @?= (mrgSingle EQ :: Union Ordering), + testCase "GEvalSym" $ do + evalSym False emptyModel AssertionError @?= AssertionError, + testCase "GExtractSym" $ do + extractSym AssertionError @?= emptySet, testCase "SimpleMergeable" $ do mrgIte "a" AssertionError AssertionError @?= AssertionError, testCase "Mergeable" $ do @@ -81,19 +81,19 @@ testCase "ToSym" $ do toSym AssertionViolation @?= AssertionViolation toSym AssumptionViolation @?= AssumptionViolation, - testCase "SEq" $ do + testCase "SymEq" $ do AssertionViolation .== AssertionViolation @?= con True AssertionViolation .== AssumptionViolation @?= con False AssumptionViolation .== AssertionViolation @?= con False AssumptionViolation .== AssumptionViolation @?= con True, - testCase "SOrd" $ do + testCase "SymOrd" $ do AssertionViolation .<= AssertionViolation @?= con True AssertionViolation .< AssertionViolation @?= con False AssertionViolation .>= AssertionViolation @?= con True AssertionViolation .> AssertionViolation @?= con False AssertionViolation `symCompare` AssertionViolation - @?= (mrgSingle EQ :: UnionM Ordering) + @?= (mrgSingle EQ :: Union Ordering) AssertionViolation .<= AssumptionViolation @?= con True AssertionViolation .< AssumptionViolation @?= con True @@ -101,7 +101,7 @@ AssertionViolation .> AssumptionViolation @?= con False AssertionViolation `symCompare` AssumptionViolation - @?= (mrgSingle LT :: UnionM Ordering) + @?= (mrgSingle LT :: Union Ordering) AssumptionViolation .<= AssertionViolation @?= con False AssumptionViolation .< AssertionViolation @?= con False @@ -109,7 +109,7 @@ AssumptionViolation .> AssertionViolation @?= con True AssumptionViolation `symCompare` AssertionViolation - @?= (mrgSingle GT :: UnionM Ordering) + @?= (mrgSingle GT :: Union Ordering) AssumptionViolation .<= AssumptionViolation @?= con True AssumptionViolation .< AssumptionViolation @?= con False @@ -117,15 +117,15 @@ AssumptionViolation .> AssumptionViolation @?= con False AssumptionViolation `symCompare` AssumptionViolation - @?= (mrgSingle EQ :: UnionM Ordering), - testCase "GEvaluateSym" $ do - evaluateSym False emptyModel AssertionViolation + @?= (mrgSingle EQ :: Union Ordering), + testCase "GEvalSym" $ do + evalSym False emptyModel AssertionViolation @?= AssertionViolation - evaluateSym False emptyModel AssumptionViolation + evalSym False emptyModel AssumptionViolation @?= AssumptionViolation, - testCase "GExtractSymbolics" $ do - extractSymbolics AssertionViolation @?= emptySet - extractSymbolics AssumptionViolation @?= emptySet, + testCase "GExtractSym" $ do + extractSym AssertionViolation @?= emptySet + extractSym AssumptionViolation @?= emptySet, testCase "Mergeable" $ do mrgIf "a" @@ -135,7 +135,7 @@ (symNot "a") (mrgSingle AssertionViolation) (mrgSingle AssumptionViolation) :: - UnionM VerificationConditions + Union VerificationConditions ), testCase "Transform VerificationConditions to VerificationConditions" @@ -144,7 +144,7 @@ transformError AssumptionViolation @?= AssumptionViolation ], testCase "symAssert" $ do - (symAssert "a" :: ExceptT VerificationConditions UnionM ()) + (symAssert "a" :: ExceptT VerificationConditions Union ()) @?= ExceptT ( mrgIf (symNot "a") diff --git a/test/Grisette/Core/Control/Monad/UnionMTests.hs b/test/Grisette/Core/Control/Monad/UnionMTests.hs deleted file mode 100644 --- a/test/Grisette/Core/Control/Monad/UnionMTests.hs +++ /dev/null @@ -1,343 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} - -{-# HLINT ignore "Use <$>" #-} - -module Grisette.Core.Control.Monad.UnionMTests (unionMTests) where - -import Control.Monad.Except (ExceptT) -import qualified Data.Text as T -import Grisette - ( EvaluateSym (evaluateSym), - ExtractSymbolics (extractSymbolics), - Function ((#)), - GPretty (gpretty), - ITEOp (symIte), - LogicalOp ((.&&)), - Mergeable (rootStrategy), - ModelOps (emptyModel), - ModelRep (buildModel), - ModelValuePair ((::=)), - PlainUnion (ifView, singleView), - SEq ((.==)), - SOrd ((.<=)), - SimpleMergeable (mrgIte), - Solvable (con, conView, isym, ssym), - SubstituteSym (substituteSym), - SymBool, - SymInteger, - SymbolSetRep (buildSymbolSet), - ToCon (toCon), - ToSym (toSym), - TryMerge (tryMergeWithStrategy), - TypedSymbol, - UnionMergeable1 (mrgIfPropagatedStrategy, mrgIfWithStrategy), - mrgIf, - mrgIte1, - mrgSingle, - tryMerge, - ) -import Grisette.Internal.Core.Control.Monad.UnionM - ( UnionM (UAny, UMrg), - isMerged, - liftToMonadUnion, - liftUnionM, - underlyingUnion, - unionMBinOp, - unionMUnaryOp, - unionSize, - ) -import Grisette.Internal.Core.Data.Union (Union (UnionSingle), ifWithLeftMost) -import Grisette.TestUtil.PrettyPrint (compactRenderedAs, renderedAs) -import Grisette.TestUtil.SymbolicAssertion ((.@?=)) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@?=)) - -unionM1 :: UnionM (Either SymBool SymInteger) -unionM1 = mrgIfPropagatedStrategy "u1c" (return $ Left "u1a") (return $ Right "u1b") - -unionM2 :: UnionM (Either SymBool SymInteger) -unionM2 = mrgIfPropagatedStrategy "u2c" (return $ Left "u2a") (return $ Right "u2b") - -unionM12 :: UnionM (Either SymBool SymInteger) -unionM12 = mrgIfPropagatedStrategy "u12c" unionM1 unionM2 - -union12Merged :: Union (Either SymBool SymInteger) -union12Merged = - ifWithLeftMost - True - (symIte "u12c" "u1c" "u2c") - (UnionSingle (Left (symIte "u12c" "u1a" "u2a"))) - (UnionSingle (Right (symIte "u12c" "u1b" "u2b"))) - -unionM12Merged :: UnionM (Either SymBool SymInteger) -unionM12Merged = UMrg rootStrategy union12Merged - -unionMSimple1 :: UnionM SymInteger -unionMSimple1 = mrgIfPropagatedStrategy "u1c" (return "u1a") (return "u1b") - -unionMSimple1Plus1 :: UnionM SymInteger -unionMSimple1Plus1 = - mrgIfPropagatedStrategy - "u1c" - (return $ "u1a" + 1) - (return $ "u1b" + 1) - -unionMSimple2 :: UnionM SymInteger -unionMSimple2 = mrgIfPropagatedStrategy "u2c" (return "u2a") (return "u2b") - -unionMSimple12Merged :: UnionM SymInteger -unionMSimple12Merged = - UMrg - rootStrategy - ( UnionSingle - (symIte "u12c" (symIte "u1c" "u1a" "u1b") (symIte "u2c" "u2a" "u2b")) - ) - -unionMTests :: Test -unionMTests = - testGroup - "UnionM" - [ testCase "underlyingUnion" $ - underlyingUnion unionM12Merged @?= union12Merged, - testCase "isMerged" $ do - isMerged unionM12 @?= False - isMerged unionM12Merged @?= True, - testCase "liftUnionM & liftToMonadUnion" $ do - let expected = - mrgSingle (symIte "u1c" "u1a" "u1b") :: ExceptT () UnionM SymInteger - liftUnionM unionMSimple1 @?= expected - liftToMonadUnion unionMSimple1 @?= expected, - testCase "unionSize" $ - unionSize unionM12Merged @?= 2, - testCase "unaryOp" $ - unionMUnaryOp (+ 1) unionMSimple1 .@?= unionMSimple1Plus1, - testCase "binOp" $ do - let actual = unionMBinOp (+) unionMSimple1 unionMSimple2 - let expected = - mrgSingle (symIte "u1c" "u1a" "u1b" + symIte "u2c" "u2a" "u2b") - actual .@?= expected, - testCase "Mergeable & TryMerge" $ - tryMergeWithStrategy rootStrategy unionM12 @?= unionM12Merged, - testCase "SimpleMerge" $ - mrgIte "u12c" unionM1 unionM2 @?= unionM12Merged, - testCase "UnionMergeable1" $ do - let actual = mrgIfWithStrategy rootStrategy "u12c" unionM1 unionM2 - actual @?= unionM12Merged, - testCase "SimpleMergeable1" $ - mrgIte1 "u12c" unionMSimple1 unionMSimple2 @?= unionMSimple12Merged, - testGroup - "PlainUnion" - [ testGroup - "SingleView" - [ testCase "is single" $ do - let actual = singleView (tryMerge unionMSimple1) - let expected = Just (symIte "u1c" "u1a" "u1b") - actual @?= expected, - testCase "is not single" $ - singleView unionMSimple1 @?= Nothing - ], - testGroup - "IfView" - [ testCase "is single" $ do - let actual = ifView (tryMerge unionMSimple1) - let expected = Nothing - actual @?= expected, - testCase "is not single (unmerged)" $ do - let actual = ifView unionMSimple1 - let expected = Just ("u1c", return "u1a", return "u1b") - actual @?= expected, - testCase "is not single (merged)" $ do - let actual = ifView (tryMerge unionM1) - let expected = - Just ("u1c", mrgSingle $ Left "u1a", mrgSingle $ Right "u1b") - actual @?= expected - ] - ], - testGroup - "Show" - [ testCase "Merged" $ do - let expected = - "{If (ite u12c u1c u2c) (Left (ite u12c u1a u2a)) " - ++ "(Right (ite u12c u1b u2b))}" - show unionM12Merged @?= expected, - testCase "Not merged" $ do - let expected = "" - show unionMSimple1 @?= expected - ], - testGroup - "GPretty" - [ testCase "Merged" $ do - gpretty unionM12Merged - `renderedAs` ( "{If (ite u12c u1c u2c) (Left (ite u12c u1a u2a)) " - <> "(Right (ite u12c u1b u2b))}" - ) - gpretty unionM12Merged - `compactRenderedAs` ( T.intercalate - "\n" - [ "{ If", - " ...", - " ( Left", - " ...", - " )", - " ( Right", - " ...", - " )", - "}" - ] - ), - testCase "Not merged" $ do - gpretty unionM1 `renderedAs` "" - ], - testGroup - "Functor" - [ testCase "fmap should work" $ do - (+ 1) <$> unionMSimple1 @?= unionMSimple1Plus1 - ], - testGroup - "Applicative" - [ testCase "pure should work" $ - (pure 1 :: UnionM Int) @?= UAny (UnionSingle 1), - testCase "<*> should work" $ - pure (+ 1) <*> unionMSimple1 @?= unionMSimple1Plus1 - ], - testGroup - "Monad" - [ testCase "return should work" $ - (return 1 :: UnionM Int) @?= UAny (UnionSingle 1), - testCase ">>= should work" $ - (unionMSimple1 >>= (\i -> return (i + 1))) @?= unionMSimple1Plus1, - testCase ">>= should propagate merge strategy" $ do - let actual = unionMSimple1 >>= (\i -> mrgSingle (i + 1)) - let expected = mrgSingle (symIte "u1c" ("u1a" + 1) ("u1b" + 1)) - actual @?= expected - ], - testCase "SEq" $ do - let actual = unionM1 .== unionM2 - let expected = - (("u1c" :: SymBool) .== "u2c") - .&& ( symIte - "u1c" - (("u1a" :: SymBool) .== "u2a") - (("u1b" :: SymInteger) .== "u2b") - ) - actual .@?= expected, - testCase "SOrd" $ do - let actual = unionM1 .<= unionM2 - let expected = - symIte - (("u1c" :: SymBool) .== "u2c") - ( symIte - "u1c" - (("u1a" :: SymBool) .<= "u2a") - (("u1b" :: SymInteger) .<= "u2b") - ) - "u1c" - actual .@?= expected, - testCase "ToSym a (UnionM b)" $ do - let actual = toSym True :: UnionM SymBool - let expected = mrgSingle (con True) - actual @?= expected, - testCase "ToSym (UnionM a) (UnionM b)" $ do - let actual = toSym (mrgSingle True :: UnionM Bool) :: UnionM SymBool - let expected = mrgSingle (con True) - actual @?= expected, - testCase "ToSym (UnionM Integer) SymInteger" $ do - let actual = toSym (mrgIf "a" 1 2 :: UnionM Integer) - let expected = symIte "a" 1 2 :: SymInteger - actual @?= expected, - testGroup - "ToCon (UnionM a) b" - [ testCase "Const" $ do - let actual = mrgSingle (con True) :: UnionM SymBool - let expected = Just True :: Maybe Bool - toCon actual @?= expected, - testCase "Not const" $ do - let actual = mrgSingle "a" :: UnionM SymBool - let expected = Nothing :: Maybe Bool - toCon actual @?= expected - ], - testGroup - "ToCon (UnionM a) (UnionM b)" - [ testCase "Const" $ do - let actual = mrgSingle (con True) :: UnionM SymBool - let expected = Just (mrgSingle True) :: Maybe (UnionM Bool) - toCon actual @?= expected, - testCase "Not const" $ do - let actual = mrgSingle "a" :: UnionM SymBool - let expected = Nothing :: Maybe (UnionM Bool) - toCon actual @?= expected - ], - testGroup "EvaluateSym" $ do - let model = buildModel ("a" ::= True, "b" ::= False, "c" ::= True) - [ testCase "EmptyModel with no fill default" $ do - let actual = evaluateSym False emptyModel (return "a") - let expected = mrgSingle "a" :: UnionM SymBool - actual @?= expected, - testCase "EmptyModel with filling default" $ do - let actual = evaluateSym True emptyModel (return "a") - let expected = mrgSingle $ con False :: UnionM SymBool - actual @?= expected, - testCase "non-empty model, simple test" $ do - let actual = evaluateSym False model (return "a") - let expected = mrgSingle $ con True :: UnionM SymBool - actual @?= expected, - testCase "non-empty model, complex test" $ do - let actual = - evaluateSym - False - model - ( mrgIf - "d" - (mrgIf "a" (mrgSingle $ Left "b") (mrgSingle $ Right "e")) - (mrgSingle $ Right "f") - ) :: - UnionM (Either SymBool SymBool) - let expected = - mrgIf "d" (mrgSingle $ Left (con False)) (mrgSingle $ Right "f") - actual .@?= expected - ], - testCase "SubstituteSym" $ do - let actual = - substituteSym - ("a" :: TypedSymbol Bool) - "b" - ( mrgIf "a" (return $ Left "a") (return $ Right "c") :: - UnionM (Either SymBool SymBool) - ) - let expected = mrgIf "b" (return $ Left "b") (return $ Right "c") - actual @?= expected, - testCase "ExtractSymbolics" $ do - let actual = extractSymbolics unionM1 - let expected = - buildSymbolSet - ( "u1c" :: TypedSymbol Bool, - "u1a" :: TypedSymbol Bool, - "u1b" :: TypedSymbol Integer - ) - actual @?= expected, - testGroup - "Solvable" - [ testCase "con" $ (con True :: UnionM SymBool) @?= mrgSingle (con True), - testCase "sym" $ (ssym "a" :: UnionM SymBool) @?= mrgSingle (ssym "a"), - testCase "isym" $ - (isym "a" 1 :: UnionM SymBool) @?= mrgSingle (isym "a" 1), - testGroup - "conView" - [ testCase "is concrete" $ do - let value = - mrgIfPropagatedStrategy - "a" - (return $ con True) - (return $ con True) - conView (value :: UnionM SymBool) @?= Just True, - testCase "not concrete" $ - conView (ssym "a" :: UnionM SymBool) @?= Nothing - ] - ], - testCase "Function" $ do - let f = mrgSingle (+ 1) :: UnionM (SymInteger -> SymInteger) - f # 1 @?= 2 - ] diff --git a/test/Grisette/Core/Control/Monad/UnionTests.hs b/test/Grisette/Core/Control/Monad/UnionTests.hs --- a/test/Grisette/Core/Control/Monad/UnionTests.hs +++ b/test/Grisette/Core/Control/Monad/UnionTests.hs @@ -1,839 +1,362 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} - -module Grisette.Core.Control.Monad.UnionTests (unionTests) where - -import GHC.Generics (Generic) -import Grisette - ( ITEOp (symIte), - LogicalOp (symNot, (.&&), (.||)), - Mergeable (rootStrategy), - MergingStrategy (SortedStrategy), - Solvable (con), - SymInteger, - wrapStrategy, - ) -import Grisette.Internal.Core.Data.Union - ( Union (UnionIf, UnionSingle), - fullReconstruct, - ifWithLeftMost, - ifWithStrategy, - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.HUnit ((@?=)) - -data TripleSum a b c = TS1 a | TS2 b | TS3 c deriving (Show, Eq, Generic) - -instance - (Mergeable a, Mergeable b, Mergeable c) => - Mergeable (TripleSum a b c) - where - rootStrategy = - SortedStrategy - (\case TS1 _ -> (0 :: Int); TS2 _ -> (1 :: Int); TS3 _ -> (2 :: Int)) - ( \case - 0 -> wrapStrategy rootStrategy TS1 (\(TS1 x) -> x) - 1 -> wrapStrategy rootStrategy TS2 (\(TS2 x) -> x) - 2 -> wrapStrategy rootStrategy TS3 (\(TS3 x) -> x) - _ -> error "Bad" - ) - -unionTests :: Test -unionTests = - testGroup - "Union" - [ testGroup - "ifWithLeftMost" - [ testCase - "ifWithLeftMost should maintain left most info on Singles" - $ do - ifWithLeftMost - False - "a" - (UnionSingle (1 :: Integer)) - (UnionSingle 2) - @?= UnionIf 1 False "a" (UnionSingle 1) (UnionSingle 2), - testCase "ifWithLeftMost should maintain left most info on Ifs" $ do - ifWithLeftMost - True - "a" - (UnionIf 1 True "b" (UnionSingle (1 :: Integer)) (UnionSingle 2)) - (UnionIf 3 True "c" (UnionSingle 3) (UnionSingle 4)) - @?= UnionIf - 1 - True - "a" - ( UnionIf - 1 - True - "b" - (UnionSingle (1 :: Integer)) - (UnionSingle 2) - ) - (UnionIf 3 True "c" (UnionSingle 3) (UnionSingle 4)) - ], - testGroup - "ifWithStrategy" - [ testGroup - "ifWithStrategy with concrete condition" - [ testCase "true" $ do - ifWithStrategy - rootStrategy - (con True) - (UnionSingle (1 :: Integer)) - (UnionSingle 2) - @?= UnionSingle 1, - testCase "false" $ do - ifWithStrategy - rootStrategy - (con False) - (UnionSingle (1 :: Integer)) - (UnionSingle 2) - @?= UnionSingle 2 - ], - let a = - ifWithStrategy - rootStrategy - "a" - (UnionSingle (1 :: Integer)) - (UnionSingle 2) - in testGroup - "ifWithStrategy with condition equal to sub conditions" - [ testCase "ifTrue" $ do - ifWithStrategy rootStrategy "a" a (UnionSingle 3) - @?= UnionIf 1 True "a" (UnionSingle 1) (UnionSingle 3), - testCase "ifFalse" $ do - ifWithStrategy rootStrategy "a" (UnionSingle 0) a - @?= UnionIf 0 True "a" (UnionSingle 0) (UnionSingle 2) - ], - testCase "ifWithStrategy with simple mergeables" $ do - ifWithStrategy - rootStrategy - "a" - (UnionSingle ("b" :: SymInteger)) - (UnionSingle "c") - @?= UnionSingle (symIte "a" "b" "c"), - testGroup - "ifWithStrategy with ordered mergeables" - [ testGroup - "ifWithStrategy on Single/Single" - [ testGroup - "idxt < idxf" - [ testCase "Integer" $ - ifWithStrategy - rootStrategy - "a" - (UnionSingle (1 :: Integer)) - (UnionSingle 2) - @?= UnionIf - 1 - True - "a" - (UnionSingle 1) - (UnionSingle 2), - testCase "Maybe Integer" $ - ifWithStrategy - rootStrategy - "a" - (UnionSingle Nothing) - (UnionSingle (Just (2 :: Integer))) - @?= UnionIf - Nothing - True - "a" - (UnionSingle Nothing) - (UnionSingle (Just 2)) - ], - testGroup - "idxt == idxf" - [ testGroup - "idxt == idxf as terminal" - [ testCase "Integer" $ - ifWithStrategy - rootStrategy - "a" - (UnionSingle (1 :: Integer)) - (UnionSingle 1) - @?= UnionSingle 1, - testCase "Maybe Integer" $ - ifWithStrategy - rootStrategy - "a" - (UnionSingle (Just ("b" :: SymInteger))) - (UnionSingle (Just "c")) - @?= UnionSingle (Just (symIte "a" "b" "c")) - ], - testGroup - "idxt == idxf but not terminal" - [ testCase "Maybe Integer" $ - ifWithStrategy - rootStrategy - "a" - (UnionSingle (Just (1 :: Integer))) - (UnionSingle (Just (2 :: Integer))) - @?= UnionIf - (Just 1) - True - "a" - (UnionSingle $ Just 1) - (UnionSingle (Just 2)), - testCase "Maybe (Maybe Integer)" $ - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ Just $ Just ("b" :: SymInteger)) - (UnionSingle $ Just $ Just "c") - @?= UnionSingle (Just (Just (symIte "a" "b" "c"))) - ] - ], - testGroup - "idxt > idxf" - [ testCase "Integer" $ - ifWithStrategy - rootStrategy - "a" - (UnionSingle (2 :: Integer)) - (UnionSingle 1) - @?= UnionIf - 1 - True - (symNot "a") - (UnionSingle 1) - (UnionSingle 2), - testCase "Maybe Integer" $ - ifWithStrategy - rootStrategy - "a" - (UnionSingle (Just (2 :: Integer))) - (UnionSingle Nothing) - @?= UnionIf - Nothing - True - (symNot "a") - (UnionSingle Nothing) - (UnionSingle (Just 2)) - ] - ], - testGroup - "ifWithStrategy on Single/If" - [ testGroup - "Degenerate to Single/Single when idxft == idxff" - [ testCase "Degenerated case with idxt < idxf" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle (Just (1 :: Integer))) - (UnionSingle (Just (2 :: Integer))) - ifWithStrategy rootStrategy "b" (UnionSingle Nothing) x - @?= UnionIf - Nothing - True - "b" - (UnionSingle Nothing) - ( UnionIf - (Just 1) - True - "a" - (UnionSingle $ Just 1) - (UnionSingle (Just 2)) - ), - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle (Just (1 :: Integer))) - (UnionSingle (Just (3 :: Integer))) - in testGroup - "Degenerated case with idxt == idxf" - [ testCase "sub-idxt < sub-idxft" $ - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ Just 0) - x - @?= UnionIf - (Just 0) - True - "b" - (UnionSingle $ Just 0) - ( UnionIf - (Just 1) - True - "a" - (UnionSingle $ Just 1) - (UnionSingle (Just 3)) - ), - testCase "sub-idxt == sub-idxft" $ - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ Just 1) - x - @?= UnionIf - (Just 1) - True - ("b" .|| "a") - (UnionSingle $ Just 1) - (UnionSingle (Just 3)), - testCase "subidxft < sub-idxt < sub-idxff" $ - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ Just 2) - x - @?= UnionIf - (Just 1) - True - ((symNot "b") .&& "a") - (UnionSingle $ Just 1) - ( UnionIf - (Just 2) - True - "b" - (UnionSingle $ Just 2) - (UnionSingle $ Just 3) - ), - testCase "sub-idxt == sub-idxff" $ - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ Just 3) - x - @?= UnionIf - (Just 1) - True - ((symNot "b") .&& "a") - (UnionSingle $ Just 1) - (UnionSingle (Just 3)), - testCase "sub-idxff < sub-idxt" $ - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ Just 4) - x - @?= UnionIf - (Just 1) - True - ((symNot "b") .&& "a") - (UnionSingle $ Just 1) - ( UnionIf - (Just 3) - True - (symNot "b") - (UnionSingle $ Just 3) - (UnionSingle $ Just 4) - ) - ], - testCase "Degenerated case with idxt > idxf" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle (Left (1 :: Integer))) - (UnionSingle (Left (2 :: Integer))) - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ Right (1 :: Integer)) - x - @?= UnionIf - (Left 1) - True - (symNot "b") - ( UnionIf - (Left 1) - True - "a" - (UnionSingle $ Left 1) - (UnionSingle (Left 2)) - ) - (UnionSingle $ Right 1) - ], - testCase "idxt < idxft" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle (1 :: Integer)) - (UnionSingle (3 :: Integer)) - ifWithStrategy rootStrategy "b" (UnionSingle 0) x - @?= UnionIf - 0 - True - "b" - (UnionSingle 0) - ( UnionIf - 1 - True - "a" - (UnionSingle 1) - (UnionSingle 3) - ), - testCase "idxt == idxft" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ Left (1 :: Integer)) - (UnionSingle $ Right (3 :: Integer)) - ifWithStrategy rootStrategy "b" (UnionSingle $ Left 0) x - @?= UnionIf - (Left 0) - True - ("b" .|| "a") - ( UnionIf - (Left 0) - True - "b" - (UnionSingle $ Left 0) - (UnionSingle $ Left 1) - ) - (UnionSingle $ Right 3), - testCase "idxt > idxft" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ Left (1 :: Integer)) - (UnionSingle $ Right (3 :: Integer)) - ifWithStrategy rootStrategy "b" (UnionSingle $ Right 0) x - @?= UnionIf - (Left 1) - True - ((symNot "b") .&& "a") - (UnionSingle $ Left 1) - ( UnionIf - (Right 0) - True - "b" - (UnionSingle $ Right 0) - (UnionSingle $ Right 3) - ) - ], - testGroup - "ifWithStrategy on If/Single" - [ testGroup - "Degenerate to Single/Single when idxtt == idxtf" - [ testCase "Degenerated case with idxt < idxf" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle (Left (1 :: Integer))) - (UnionSingle (Left (2 :: Integer))) - ifWithStrategy - rootStrategy - "b" - x - (UnionSingle $ Right (2 :: Integer)) - @?= UnionIf - (Left 1) - True - "b" - ( UnionIf - (Left 1) - True - "a" - (UnionSingle $ Left 1) - (UnionSingle (Left 2)) - ) - (UnionSingle $ Right 2), - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle (Just (1 :: Integer))) - (UnionSingle (Just (3 :: Integer))) - in testGroup - "Degenerated case with idxt == idxf" - [ testCase "sub-idxf < sub-idxtt" $ - ifWithStrategy - rootStrategy - "b" - x - (UnionSingle $ Just 0) - @?= UnionIf - (Just 0) - True - (symNot "b") - (UnionSingle $ Just 0) - ( UnionIf - (Just 1) - True - "a" - (UnionSingle $ Just 1) - (UnionSingle (Just 3)) - ), - testCase "sub-idxf == sub-idxtt" $ - ifWithStrategy - rootStrategy - "b" - x - (UnionSingle $ Just 1) - @?= UnionIf - (Just 1) - True - ((symNot "b") .|| "a") - (UnionSingle $ Just 1) - (UnionSingle (Just 3)), - testCase "sub-idxtt < sub-idxf < sub-idxtf" $ - ifWithStrategy - rootStrategy - "b" - x - (UnionSingle $ Just 2) - @?= UnionIf - (Just 1) - True - ("b" .&& "a") - (UnionSingle $ Just 1) - ( UnionIf - (Just 2) - True - (symNot "b") - (UnionSingle $ Just 2) - (UnionSingle $ Just 3) - ), - testCase "sub-idxf == sub-idxtf" $ - ifWithStrategy - rootStrategy - "b" - x - (UnionSingle $ Just 3) - @?= UnionIf - (Just 1) - True - ("b" .&& "a") - (UnionSingle $ Just 1) - (UnionSingle (Just 3)), - testCase "sub-idxtf < sub-idxf" $ - ifWithStrategy - rootStrategy - "b" - x - (UnionSingle $ Just 4) - @?= UnionIf - (Just 1) - True - ("b" .&& "a") - (UnionSingle $ Just 1) - ( UnionIf - (Just 3) - True - "b" - (UnionSingle $ Just 3) - (UnionSingle $ Just 4) - ) - ], - testCase "Degenerated case with idxt > idxf" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle (Right (1 :: Integer))) - (UnionSingle (Right (2 :: Integer))) - ifWithStrategy - rootStrategy - "b" - x - (UnionSingle $ Left (1 :: Integer)) - @?= UnionIf - (Left 1) - True - (symNot "b") - (UnionSingle $ Left 1) - ( UnionIf - (Right 1) - True - "a" - (UnionSingle $ Right 1) - (UnionSingle (Right 2)) - ) - ], - testCase "idxtt < idxf" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ Left (1 :: Integer)) - (UnionSingle $ Right (3 :: Integer)) - ifWithStrategy rootStrategy "b" x (UnionSingle $ Right 0) - @?= UnionIf - (Left 1) - True - ("b" .&& "a") - (UnionSingle $ Left 1) - ( UnionIf - (Right 0) - True - (symNot "b") - (UnionSingle $ Right 0) - (UnionSingle $ Right 3) - ), - testCase "idxtt == idxf" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ Left (1 :: Integer)) - (UnionSingle $ Right (3 :: Integer)) - ifWithStrategy rootStrategy "b" x (UnionSingle $ Left 0) - @?= UnionIf - (Left 0) - True - ((symNot "b") .|| "a") - ( UnionIf - (Left 0) - True - (symNot "b") - (UnionSingle $ Left 0) - (UnionSingle $ Left 1) - ) - (UnionSingle $ Right 3), - testCase "idxtt > idxf" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle (1 :: Integer)) - (UnionSingle (3 :: Integer)) - ifWithStrategy rootStrategy "b" x (UnionSingle 0) - @?= UnionIf - 0 - True - (symNot "b") - (UnionSingle 0) - (UnionIf 1 True "a" (UnionSingle 1) (UnionSingle 3)) - ], - testGroup - "ifWithStrategy on If/If" - [ testCase "Degenerate to Single/If when idxtt == idxtf" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ Left (1 :: Integer)) - (UnionSingle $ Left (2 :: Integer)) - let y = - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ Left (1 :: Integer)) - (UnionSingle $ Right (2 :: Integer)) - ifWithStrategy rootStrategy "c" x y - @?= UnionIf - (Left 1) - True - ("c" .|| "b") - ( UnionIf - (Left 1) - True - ((symNot "c") .|| "a") - (UnionSingle $ Left 1) - (UnionSingle $ Left 2) - ) - (UnionSingle $ Right 2), - testCase "Degenerate to Single/If when idxff == idxft" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ Left (1 :: Integer)) - (UnionSingle $ Left (2 :: Integer)) - let y = - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ Left (1 :: Integer)) - (UnionSingle $ Right (2 :: Integer)) - ifWithStrategy rootStrategy "c" y x - @?= UnionIf - (Left 1) - True - ((symNot "c") .|| "b") - ( UnionIf - (Left 1) - True - ("c" .|| "a") - (UnionSingle $ Left 1) - (UnionSingle $ Left 2) - ) - (UnionSingle $ Right 2), - testCase "Non-degenerated case when idxtt < idxft" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ TS1 (1 :: Integer)) - (UnionSingle $ TS2 (2 :: Integer)) - let y = - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ TS2 (1 :: Integer)) - (UnionSingle $ TS3 (2 :: Integer)) - ifWithStrategy rootStrategy "c" x y - @?= UnionIf - (TS1 1) - True - ("c" .&& "a") - (UnionSingle $ TS1 1) - ( UnionIf - (TS2 1) - True - ("c" .|| "b") - ( UnionIf - (TS2 1) - True - (symNot "c") - (UnionSingle $ TS2 1) - (UnionSingle $ TS2 2) - ) - (UnionSingle $ TS3 2) - ), - testCase "Non-degenerated case when idxtt == idxft" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ TS1 (1 :: Integer)) - (UnionSingle $ TS2 (2 :: Integer)) - let y = - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ TS1 (2 :: Integer)) - (UnionSingle $ TS3 (2 :: Integer)) - ifWithStrategy rootStrategy "c" x y - @?= UnionIf - (TS1 1) - True - (symIte "c" "a" "b") - ( UnionIf - (TS1 1) - True - "c" - (UnionSingle $ TS1 1) - (UnionSingle $ TS1 2) - ) - ( UnionIf - (TS2 2) - True - "c" - (UnionSingle $ TS2 2) - (UnionSingle $ TS3 2) - ), - testCase "Non-degenerated case when idxtt > idxft" $ do - let x = - ifWithStrategy - rootStrategy - "a" - (UnionSingle $ TS2 (1 :: Integer)) - (UnionSingle $ TS3 (2 :: Integer)) - let y = - ifWithStrategy - rootStrategy - "b" - (UnionSingle $ TS1 (1 :: Integer)) - (UnionSingle $ TS2 (2 :: Integer)) - ifWithStrategy rootStrategy "c" x y - @?= UnionIf - (TS1 1) - True - ((symNot "c") .&& "b") - (UnionSingle $ TS1 1) - ( UnionIf - (TS2 1) - True - ((symNot "c") .|| "a") - ( UnionIf - (TS2 1) - True - "c" - (UnionSingle $ TS2 1) - (UnionSingle $ TS2 2) - ) - (UnionSingle $ TS3 2) - ) - ], - testCase "ifWithStrategy should tolerate non-merged Ifs" $ do - let x = - UnionIf - (Right 2) - False - "a" - (UnionSingle $ Right (2 :: Integer)) - (UnionSingle $ Left (2 :: Integer)) - let y = - UnionIf - (Right 3) - False - "b" - (UnionSingle $ Right 3) - (UnionSingle $ Left 1) - ifWithStrategy rootStrategy "c" x y - @?= UnionIf - (Left 1) - True - (symIte "c" (symNot "a") (symNot "b")) - ( UnionIf - (Left 1) - True - (symNot "c") - (UnionSingle $ Left 1) - (UnionSingle $ Left 2) - ) - ( UnionIf - (Right 2) - True - "c" - (UnionSingle $ Right 2) - (UnionSingle $ Right 3) - ) - ] - ], - testGroup - "fullReconstruct" - [ testCase "fullReconstruct should work" $ do - let x = - UnionIf - (Right 2) - False - "a" - (UnionSingle $ Right (2 :: Integer)) - (UnionSingle $ Left (2 :: Integer)) - let y = - UnionIf - (Right 3) - False - "b" - (UnionSingle $ Right 3) - (UnionSingle $ Left 1) - let z = UnionIf (Right 2) False "c" x y - fullReconstruct rootStrategy z - @?= UnionIf - (Left 1) - True - (symIte "c" (symNot "a") (symNot "b")) - ( UnionIf - (Left 1) - True - (symNot "c") - (UnionSingle $ Left 1) - (UnionSingle $ Left 2) - ) - ( UnionIf - (Right 2) - True - "c" - (UnionSingle $ Right 2) - (UnionSingle $ Right 3) - ) - ] +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Use <$>" #-} + +module Grisette.Core.Control.Monad.UnionTests (unionTests) where + +import Control.Monad.Except (ExceptT) +import Control.Monad.Identity (Identity (Identity)) +import qualified Data.Text as T +import Grisette + ( EvalSym (evalSym), + ExtractSym (extractSym), + Function ((#)), + ITEOp (symIte), + LogicalOp ((.&&)), + Mergeable (rootStrategy), + ModelOps (emptyModel), + ModelRep (buildModel), + ModelValuePair ((::=)), + PPrint (pformat), + PlainUnion (ifView, singleView), + SimpleMergeable (mrgIte), + Solvable (con, conView, isym, ssym), + SubstSym (substSym), + SymBool, + SymBranching (mrgIfPropagatedStrategy, mrgIfWithStrategy), + SymEq ((.==)), + SymInteger, + SymOrd ((.<=)), + SymbolSetRep (buildSymbolSet), + ToCon (toCon), + ToSym (toSym), + TryMerge (tryMergeWithStrategy), + TypedSymbol, + mrgIf, + mrgIte1, + mrgSingle, + tryMerge, + ) +import Grisette.Internal.Core.Control.Monad.Union + ( Union (UAny, UMrg), + isMerged, + liftToMonadUnion, + liftUnion, + unionBase, + unionBinOp, + unionSize, + unionUnaryOp, + ) +import Grisette.Internal.Core.Data.UnionBase + ( UnionBase (UnionSingle), + ifWithLeftMost, + ) +import Grisette.TestUtil.PrettyPrint (compactRenderedAs, renderedAs) +import Grisette.TestUtil.SymbolicAssertion ((.@?=)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +union1 :: Union (Either SymBool SymInteger) +union1 = mrgIfPropagatedStrategy "u1c" (return $ Left "u1a") (return $ Right "u1b") + +union2 :: Union (Either SymBool SymInteger) +union2 = mrgIfPropagatedStrategy "u2c" (return $ Left "u2a") (return $ Right "u2b") + +union12 :: Union (Either SymBool SymInteger) +union12 = mrgIfPropagatedStrategy "u12c" union1 union2 + +unionBase12Merged :: UnionBase (Either SymBool SymInteger) +unionBase12Merged = + ifWithLeftMost + True + (symIte "u12c" "u1c" "u2c") + (UnionSingle (Left (symIte "u12c" "u1a" "u2a"))) + (UnionSingle (Right (symIte "u12c" "u1b" "u2b"))) + +union12Merged :: Union (Either SymBool SymInteger) +union12Merged = UMrg rootStrategy unionBase12Merged + +unionSimple1 :: Union SymInteger +unionSimple1 = mrgIfPropagatedStrategy "u1c" (return "u1a") (return "u1b") + +unionSimple1Plus1 :: Union SymInteger +unionSimple1Plus1 = + mrgIfPropagatedStrategy + "u1c" + (return $ "u1a" + 1) + (return $ "u1b" + 1) + +unionSimple2 :: Union SymInteger +unionSimple2 = mrgIfPropagatedStrategy "u2c" (return "u2a") (return "u2b") + +unionSimple12Merged :: Union SymInteger +unionSimple12Merged = + UMrg + rootStrategy + ( UnionSingle + (symIte "u12c" (symIte "u1c" "u1a" "u1b") (symIte "u2c" "u2a" "u2b")) + ) + +unionTests :: Test +unionTests = + testGroup + "Union" + [ testCase "unionBase" $ + unionBase union12Merged @?= unionBase12Merged, + testCase "isMerged" $ do + isMerged union12 @?= False + isMerged union12Merged @?= True, + testCase "liftUnion & liftToMonadUnion" $ do + let expected = + mrgSingle (symIte "u1c" "u1a" "u1b") :: ExceptT () Union SymInteger + liftUnion unionSimple1 @?= expected + liftToMonadUnion unionSimple1 @?= expected, + testCase "unionSize" $ + unionSize union12Merged @?= 2, + testCase "unaryOp" $ + unionUnaryOp (+ 1) unionSimple1 .@?= unionSimple1Plus1, + testCase "binOp" $ do + let actual = unionBinOp (+) unionSimple1 unionSimple2 + let expected = + mrgSingle (symIte "u1c" "u1a" "u1b" + symIte "u2c" "u2a" "u2b") + actual .@?= expected, + testCase "Mergeable & TryMerge" $ + tryMergeWithStrategy rootStrategy union12 @?= union12Merged, + testCase "SimpleMerge" $ + mrgIte "u12c" union1 union2 @?= union12Merged, + testCase "SymBranching" $ do + let actual = mrgIfWithStrategy rootStrategy "u12c" union1 union2 + actual @?= union12Merged, + testCase "SimpleMergeable1" $ + mrgIte1 "u12c" unionSimple1 unionSimple2 @?= unionSimple12Merged, + testGroup + "PlainUnion" + [ testGroup + "SingleView" + [ testCase "is single" $ do + let actual = singleView (tryMerge unionSimple1) + let expected = Just (symIte "u1c" "u1a" "u1b") + actual @?= expected, + testCase "is not single" $ + singleView unionSimple1 @?= Nothing + ], + testGroup + "IfView" + [ testCase "is single" $ do + let actual = ifView (tryMerge unionSimple1) + let expected = Nothing + actual @?= expected, + testCase "is not single (unmerged)" $ do + let actual = ifView unionSimple1 + let expected = Just ("u1c", return "u1a", return "u1b") + actual @?= expected, + testCase "is not single (merged)" $ do + let actual = ifView (tryMerge union1) + let expected = + Just ("u1c", mrgSingle $ Left "u1a", mrgSingle $ Right "u1b") + actual @?= expected + ] + ], + testGroup + "Show" + [ testCase "Merged" $ do + let expected = + "{If (ite u12c u1c u2c) (Left (ite u12c u1a u2a)) " + ++ "(Right (ite u12c u1b u2b))}" + show union12Merged @?= expected, + testCase "Not merged" $ do + let expected = "" + show unionSimple1 @?= expected + ], + testGroup + "PPrint" + [ testCase "Merged" $ do + pformat union12Merged + `renderedAs` ( "{If (ite u12c u1c u2c) (Left (ite u12c u1a u2a)) " + <> "(Right (ite u12c u1b u2b))}" + ) + pformat union12Merged + `compactRenderedAs` ( T.intercalate + "\n" + [ "{ If", + " ...", + " ( Left", + " ...", + " )", + " ( Right", + " ...", + " )", + "}" + ] + ), + testCase "Not merged" $ do + pformat union1 `renderedAs` "" + ], + testGroup + "Functor" + [ testCase "fmap should work" $ do + (+ 1) <$> unionSimple1 @?= unionSimple1Plus1 + ], + testGroup + "Applicative" + [ testCase "pure should work" $ + (pure 1 :: Union Int) @?= UAny (UnionSingle 1), + testCase "<*> should work" $ + pure (+ 1) <*> unionSimple1 @?= unionSimple1Plus1 + ], + testGroup + "Monad" + [ testCase "return should work" $ + (return 1 :: Union Int) @?= UAny (UnionSingle 1), + testCase ">>= should work" $ + (unionSimple1 >>= (\i -> return (i + 1))) @?= unionSimple1Plus1, + testCase ">>= should propagate merge strategy" $ do + let actual = unionSimple1 >>= (\i -> mrgSingle (i + 1)) + let expected = mrgSingle (symIte "u1c" ("u1a" + 1) ("u1b" + 1)) + actual @?= expected + ], + testCase "SymEq" $ do + let actual = union1 .== union2 + let expected = + (("u1c" :: SymBool) .== "u2c") + .&& ( symIte + "u1c" + (("u1a" :: SymBool) .== "u2a") + (("u1b" :: SymInteger) .== "u2b") + ) + actual .@?= expected, + testCase "SymOrd" $ do + let actual = union1 .<= union2 + let expected = + symIte + (("u1c" :: SymBool) .== "u2c") + ( symIte + "u1c" + (("u1a" :: SymBool) .<= "u2a") + (("u1b" :: SymInteger) .<= "u2b") + ) + "u1c" + actual .@?= expected, + testCase "ToSym a (Union b)" $ do + let actual = toSym True :: Union SymBool + let expected = mrgSingle (con True) + actual @?= expected, + testCase "ToSym (Identity a) (Union b)" $ do + let actual = toSym $ Identity True :: Union SymBool + let expected = mrgSingle (con True) + actual @?= expected, + testCase "ToSym (Union a) (Union b)" $ do + let actual = toSym (mrgSingle True :: Union Bool) :: Union SymBool + let expected = return (con True) + actual @?= expected, + testCase "ToSym (Union Integer) SymInteger" $ do + let actual = toSym (mrgIf "a" 1 2 :: Union Integer) + let expected = symIte "a" 1 2 :: SymInteger + actual @?= expected, + testGroup + "ToCon (Union a) b" + [ testCase "Const" $ do + let actual = mrgSingle (con True) :: Union SymBool + let expected = Just True :: Maybe Bool + toCon actual @?= expected, + testCase "Not const" $ do + let actual = mrgSingle "a" :: Union SymBool + let expected = Nothing :: Maybe Bool + toCon actual @?= expected + ], + testGroup + "ToCon (Union a) (Identity b)" + [ testCase "Const" $ do + let actual = mrgSingle (con True) :: Union SymBool + let expected = Just (Identity True) :: Maybe (Identity Bool) + toCon actual @?= expected, + testCase "Not const" $ do + let actual = mrgSingle "a" :: Union SymBool + let expected = Nothing :: Maybe (Identity Bool) + toCon actual @?= expected + ], + testGroup + "ToCon (Union a) (Union b)" + [ testCase "Const" $ do + let actual = mrgSingle (con True) :: Union SymBool + let expected = Just (return True) :: Maybe (Union Bool) + toCon actual @?= expected, + testCase "Not const" $ do + let actual = mrgSingle "a" :: Union SymBool + let expected = Nothing :: Maybe (Union Bool) + toCon actual @?= expected + ], + testGroup "EvalSym" $ do + let model = buildModel ("a" ::= True, "b" ::= False, "c" ::= True) + [ testCase "EmptyModel with no fill default" $ do + let actual = evalSym False emptyModel (mrgSingle "a") + let expected = mrgSingle "a" :: Union SymBool + actual @?= expected, + testCase "EmptyModel with filling default" $ do + let actual = evalSym True emptyModel (mrgSingle "a") + let expected = mrgSingle $ con False :: Union SymBool + actual @?= expected, + testCase "non-empty model, simple test" $ do + let actual = evalSym False model (mrgSingle "a") + let expected = mrgSingle $ con True :: Union SymBool + actual @?= expected, + testCase "non-empty model, complex test" $ do + let actual = + evalSym + False + model + ( mrgIf + "d" + (mrgIf "a" (mrgSingle $ Left "b") (mrgSingle $ Right "e")) + (mrgSingle $ Right "f") + ) :: + Union (Either SymBool SymBool) + let expected = + mrgIf "d" (mrgSingle $ Left (con False)) (mrgSingle $ Right "f") + actual .@?= expected + ], + testCase "SubstSym" $ do + let actual = + substSym + ("a" :: TypedSymbol Bool) + "b" + ( mrgIf "a" (return $ Left "a") (return $ Right "c") :: + Union (Either SymBool SymBool) + ) + let expected = mrgIf "b" (return $ Left "b") (return $ Right "c") + actual @?= expected, + testCase "ExtractSym" $ do + let actual = extractSym union1 + let expected = + buildSymbolSet + ( "u1c" :: TypedSymbol Bool, + "u1a" :: TypedSymbol Bool, + "u1b" :: TypedSymbol Integer + ) + actual @?= expected, + testGroup + "Solvable" + [ testCase "con" $ (con True :: Union SymBool) @?= mrgSingle (con True), + testCase "sym" $ (ssym "a" :: Union SymBool) @?= mrgSingle (ssym "a"), + testCase "isym" $ + (isym "a" 1 :: Union SymBool) @?= mrgSingle (isym "a" 1), + testGroup + "conView" + [ testCase "is concrete" $ do + let value = + mrgIfPropagatedStrategy + "a" + (return $ con True) + (return $ con True) + conView (value :: Union SymBool) @?= Just True, + testCase "not concrete" $ + conView (ssym "a" :: Union SymBool) @?= Nothing + ] + ], + testCase "Function" $ do + let f = mrgSingle (+ 1) :: Union (SymInteger -> SymInteger) + f # 1 @?= 2 ] diff --git a/test/Grisette/Core/Data/Class/BoolTests.hs b/test/Grisette/Core/Data/Class/BoolTests.hs --- a/test/Grisette/Core/Data/Class/BoolTests.hs +++ b/test/Grisette/Core/Data/Class/BoolTests.hs @@ -1,30 +1,36 @@ module Grisette.Core.Data.Class.BoolTests (boolTests) where import Grisette - ( LogicalOp (symImplies, symNot, symXor, (.&&), (.||)), + ( LogicalOp (false, symImplies, symNot, symXor, true, (.&&), (.||)), ) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) data CustomAndBool - = CASBool String + = CACBool Bool + | CASBool String | CAAnd CustomAndBool CustomAndBool | CANot CustomAndBool deriving (Show, Eq) instance LogicalOp CustomAndBool where + true = CACBool True + symNot (CACBool b) = CACBool $ not b symNot (CANot x) = x symNot x = CANot x (.&&) = CAAnd data CustomOrBool - = COSBool String + = COCBool Bool + | COSBool String | COOr CustomOrBool CustomOrBool | CONot CustomOrBool deriving (Show, Eq) instance LogicalOp CustomOrBool where + false = COCBool False + symNot (COCBool b) = COCBool $ not b symNot (CONot x) = x symNot x = CONot x (.||) = COOr diff --git a/test/Grisette/Core/Data/Class/EvalSymTests.hs b/test/Grisette/Core/Data/Class/EvalSymTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/EvalSymTests.hs @@ -0,0 +1,928 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Core.Data.Class.EvalSymTests (evalSymTests) where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum (InL, InR)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Stack (HasCallStack) +import Grisette + ( EvalSym (evalSym), + ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + ModelOps (emptyModel), + ModelRep (buildModel), + ModelValuePair ((::=)), + Solvable (con, isym, ssym), + SymBool, + SymEq ((.==)), + Symbol (IndexedSymbol), + TypedSymbol (TypedSymbol), + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, (@?=)) +import Test.QuickCheck (ioProperty) + +concreteEvalSymOkProp :: + (HasCallStack, EvalSym a, Show a, Eq a) => a -> Assertion +concreteEvalSymOkProp x = evalSym True emptyModel x @?= x + +evalSymTests :: Test +evalSymTests = + testGroup + "EvalSym" + [ testGroup + "EvalSym for common types" + [ testGroup + "SymBool" + [ let model = emptyModel + eval :: SymBool -> SymBool + eval = evalSym False model + in testGroup + "Empty model / no fill default" + [ testCase "con" $ + eval (con True) @?= con True, + testCase "ssym" $ + eval (ssym "a") @?= ssym "a", + testCase "isym" $ + eval (isym "a" 1) @?= isym "a" 1, + testCase ".||" $ + eval (ssym "a" .|| ssym "b") + @?= ssym "a" + .|| ssym "b", + testCase ".&&" $ + eval (ssym "a" .&& ssym "b") + @?= ssym "a" + .&& ssym "b", + testCase ".==" $ + eval ((ssym "a" :: SymBool) .== ssym "b") + @?= (ssym "a" :: SymBool) + .== ssym "b", + testCase "symNot" $ + eval (symNot (ssym "a")) + @?= symNot (ssym "a"), + testCase "symIte" $ + eval (symIte (ssym "a") (ssym "b") (ssym "c")) + @?= symIte (ssym "a") (ssym "b") (ssym "c") + ], + let model = emptyModel + eval :: SymBool -> SymBool + eval = evalSym True model + in testGroup + "Empty model / with fill default" + [ testCase "con" $ + eval (con True) @?= con True, + testCase "ssym" $ + eval (ssym "a") @?= con False, + testCase "isym" $ + eval (isym "a" 1) @?= con False, + testCase ".||" $ + eval (ssym "a" .|| ssym "b") @?= con False, + testCase ".&&" $ + eval (ssym "a" .&& ssym "b") @?= con False, + testCase ".==" $ + eval ((ssym "a" :: SymBool) .== ssym "b") @?= con True, + testCase "symNot" $ + eval (symNot (ssym "a")) @?= con True, + testCase "symIte" $ + eval (symIte (ssym "a") (ssym "b") (ssym "c")) + @?= con False + ], + let model = + buildModel + ( "a" ::= True, + TypedSymbol (IndexedSymbol "a" 1) ::= False, + "b" ::= False, + "c" ::= True + ) + eval :: SymBool -> SymBool + eval = evalSym True model + in testGroup + "Some model" + [ testCase "con" $ + eval (con True) @?= con True, + testCase "ssym" $ + eval (ssym "a") @?= con True, + testCase "isym" $ + eval (isym "a" 1) @?= con False, + testCase ".||" $ + eval (ssym "a" .|| ssym "b") @?= con True, + testCase ".&&" $ + eval (ssym "a" .&& ssym "b") @?= con False, + testCase ".==" $ + eval ((ssym "a" :: SymBool) .== ssym "b") @?= con False, + testCase "symNot" $ + eval (symNot (ssym "a")) @?= con False, + testCase "symIte" $ + eval (symIte (ssym "a") (ssym "b") (ssym "c")) + @?= con False + ] + ], + testProperty "Bool" $ ioProperty . concreteEvalSymOkProp @Bool, + testProperty "Integer" $ + ioProperty . concreteEvalSymOkProp @Integer, + testProperty "Char" $ ioProperty . concreteEvalSymOkProp @Char, + testProperty "Int" $ ioProperty . concreteEvalSymOkProp @Int, + testProperty "Int8" $ ioProperty . concreteEvalSymOkProp @Int8, + testProperty "Int16" $ ioProperty . concreteEvalSymOkProp @Int16, + testProperty "Int32" $ ioProperty . concreteEvalSymOkProp @Int32, + testProperty "Int64" $ ioProperty . concreteEvalSymOkProp @Int64, + testProperty "Word" $ ioProperty . concreteEvalSymOkProp @Word, + testProperty "Word8" $ ioProperty . concreteEvalSymOkProp @Word8, + testProperty "Word16" $ + ioProperty . concreteEvalSymOkProp @Word16, + testProperty "Word32" $ + ioProperty . concreteEvalSymOkProp @Word32, + testProperty "Word64" $ + ioProperty . concreteEvalSymOkProp @Word64, + testGroup + "List" + [ testProperty "[Integer]" $ + ioProperty . concreteEvalSymOkProp @[Integer], + let model = + buildModel ("a" ::= True, "b" ::= False) + eval :: Bool -> [SymBool] -> [SymBool] + eval = flip evalSym model + in testGroup + "[SymBool]" + [ testGroup + "No fill default" + [ testCase "Empty list" $ + eval False [] @?= [], + testCase "Non-empty list" $ + eval False [ssym "a", ssym "b", ssym "c"] + @?= [con True, con False, ssym "c"] + ], + testGroup + "Fill default" + [ testCase "Empty list" $ + eval True [] @?= [], + testCase "Non-empty list" $ + eval True [ssym "a", ssym "b", ssym "c"] + @?= [con True, con False, con False] + ] + ] + ], + testGroup + "Maybe" + [ testProperty "Maybe Integer" $ + ioProperty . concreteEvalSymOkProp @(Maybe Integer), + let model = buildModel ("a" ::= True) + eval :: Bool -> Maybe SymBool -> Maybe SymBool + eval = flip evalSym model + in testGroup + "Maybe SymBool" + [ testGroup + "No fill default" + [ testCase "Nothing" $ + eval False Nothing @?= Nothing, + testCase "Just v: v in model" $ + eval False (Just (ssym "a")) @?= Just (con True), + testCase "Just v: v not in model" $ + eval False (Just (ssym "b")) @?= Just (ssym "b") + ], + testGroup + "Fill default" + [ testCase "Nothing" $ + eval True (Nothing) @?= Nothing, + testCase "Just v: v in model" $ + eval True (Just (ssym "a")) @?= Just (con True), + testCase "Just v: v not in model" $ + eval True (Just (ssym "b")) @?= Just (con False) + ] + ] + ], + testGroup + "Either" + [ testProperty "Either Integer Integer" $ + ioProperty + . concreteEvalSymOkProp @(Either Integer Integer), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + Either SymBool SymBool -> + Either SymBool SymBool + eval = flip evalSym model + in testGroup + "Either SymBool SymBool" + [ testGroup + "No fill default" + [ testCase "Left v: v in model" $ + eval False (Left (ssym "a")) @?= Left (con True), + testCase "Left v: v not in model" $ + eval False (Left (ssym "b")) @?= Left (ssym "b"), + testCase "Right v: v in model" $ + eval False (Right (ssym "a")) @?= Right (con True), + testCase "Right v: v not in model" $ + eval False (Right (ssym "b")) @?= Right (ssym "b") + ], + testGroup + "Fill default" + [ testCase "Left v: v in model" $ + eval True (Left (ssym "a")) @?= Left (con True), + testCase "Left v: v not in model" $ + eval True (Left (ssym "b")) @?= Left (con False), + testCase "Right v: v in model" $ + eval True (Right (ssym "a")) @?= Right (con True), + testCase "Right v: v not in model" $ + eval True (Right (ssym "b")) @?= Right (con False) + ] + ] + ], + testGroup + "MaybeT" + [ testProperty "MaybeT Maybe Integer" $ + ioProperty + . concreteEvalSymOkProp @(MaybeT Maybe Integer) + . MaybeT, + let model = buildModel ("a" ::= True) + eval :: + Bool -> + MaybeT Maybe SymBool -> + MaybeT Maybe SymBool + eval = flip evalSym model + in testGroup + "MaybeT should work" + [ testGroup + "No fill default" + [ testCase "MaybeT Nothing" $ + eval False (MaybeT Nothing) @?= MaybeT Nothing, + testCase "MaybeT (Just Nothing)" $ + eval False (MaybeT $ Just Nothing) + @?= MaybeT (Just Nothing), + testCase "MaybeT (Just v): v in model" $ + eval False (MaybeT $ Just $ Just (ssym "a")) + @?= MaybeT (Just (Just (con True))), + testCase "MaybeT (Just v): v not in model" $ + eval False (MaybeT $ Just $ Just (ssym "b")) + @?= MaybeT (Just (Just (ssym "b"))) + ], + testGroup + "Fill default" + [ testCase "MaybeT Nothing" $ + eval True (MaybeT Nothing) @?= MaybeT Nothing, + testCase "MaybeT (Just Nothing)" $ + eval True (MaybeT $ Just Nothing) + @?= MaybeT (Just Nothing), + testCase "MaybeT (Just v): v in model" $ + eval True (MaybeT $ Just $ Just (ssym "a")) + @?= MaybeT (Just (Just (con True))), + testCase "MaybeT (Just v): v not in model" $ + eval True (MaybeT $ Just $ Just (ssym "b")) + @?= MaybeT (Just (Just (con False))) + ] + ] + ], + testGroup + "ExceptT" + [ testProperty "ExceptT Integer Maybe Integer" $ + ioProperty + . concreteEvalSymOkProp @(ExceptT Integer Maybe Integer) + . ExceptT, + let model = buildModel ("a" ::= True) + eval :: + Bool -> + ExceptT SymBool Maybe SymBool -> + ExceptT SymBool Maybe SymBool + eval = flip evalSym model + in testGroup + "ExceptT SymBool Maybe SymBool" + [ testGroup + "No fill default" + [ testCase "ExceptT Nothing" $ + eval False (ExceptT Nothing) @?= ExceptT Nothing, + testCase "ExceptT (Just (Left v)): v in model" $ + eval False (ExceptT $ Just $ Left $ ssym "a") + @?= ExceptT (Just $ Left $ con True), + testCase "ExceptT (Just (Left v)): v not in model" $ + eval False (ExceptT $ Just $ Left $ ssym "b") + @?= ExceptT (Just $ Left $ ssym "b"), + testCase "ExceptT (Just (Right v)): v in model" $ + eval False (ExceptT $ Just $ Right $ ssym "a") + @?= ExceptT (Just $ Right $ con True), + testCase "ExceptT (Just (Right v)): v not in model" $ + eval False (ExceptT $ Just $ Right $ ssym "b") + @?= ExceptT (Just $ Right $ ssym "b") + ], + testGroup + "Fill default" + [ testCase "ExceptT Nothing" $ + eval True (ExceptT Nothing) @?= ExceptT Nothing, + testCase "ExceptT (Just (Left v)): v in model" $ + eval True (ExceptT $ Just $ Left $ ssym "a") + @?= ExceptT (Just $ Left $ con True), + testCase "ExceptT (Just (Left v)): v not in model" $ + eval True (ExceptT $ Just $ Left $ ssym "b") + @?= ExceptT (Just $ Left $ con False), + testCase "ExceptT (Just (Right v)): v in model" $ + eval True (ExceptT $ Just $ Right $ ssym "a") + @?= ExceptT (Just $ Right $ con True), + testCase "ExceptT (Just (Right v)): v not in model" $ + eval True (ExceptT $ Just $ Right $ ssym "b") + @?= ExceptT (Just $ Right $ con False) + ] + ] + ], + testProperty "()" (ioProperty . concreteEvalSymOkProp @()), + testGroup + "(,)" + [ testProperty "(Integer, Integer)" $ + ioProperty . concreteEvalSymOkProp @(Integer, Integer), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + (SymBool, SymBool) -> + (SymBool, SymBool) + eval = flip evalSym model + in testGroup + "(SymBool, SymBool)" + [ testCase "No fill default" $ + eval False (ssym "a", ssym "b") + @?= (con True, ssym "b"), + testCase "Fill default" $ + eval True (ssym "a", ssym "b") + @?= (con True, con False) + ] + ], + testGroup + "(,,)" + [ testProperty "(Integer, Integer, Integer)" $ + ioProperty + . concreteEvalSymOkProp @(Integer, Integer, Integer), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + (SymBool, SymBool, SymBool) -> + (SymBool, SymBool, SymBool) + eval = flip evalSym model + in testGroup + "(SymBool, SymBool, SymBool)" + [ testCase "No fill default" $ + eval False (ssym "a", ssym "b", ssym "c") + @?= (con True, ssym "b", ssym "c"), + testCase "Fill default" $ + eval True (ssym "a", ssym "b", ssym "c") + @?= (con True, con False, con False) + ] + ], + testGroup + "(,,,)" + [ testProperty "(Integer, Integer, Integer, Integer)" $ + ioProperty + . concreteEvalSymOkProp + @(Integer, Integer, Integer, Integer), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + (SymBool, SymBool, SymBool, SymBool) -> + (SymBool, SymBool, SymBool, SymBool) + eval = flip evalSym model + in testGroup + "(SymBool, SymBool, SymBool, SymBool)" + [ testCase "No fill default" $ + eval False (ssym "a", ssym "b", ssym "c", ssym "d") + @?= (con True, ssym "b", ssym "c", ssym "d"), + testCase "Fill default" $ + eval True (ssym "a", ssym "b", ssym "c", ssym "d") + @?= (con True, con False, con False, con False) + ] + ], + testGroup + "(,,,,)" + [ testProperty "(Integer, Integer, Integer, Integer, Integer)" $ + ioProperty + . concreteEvalSymOkProp + @(Integer, Integer, Integer, Integer, Integer), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + (SymBool, SymBool, SymBool, SymBool, SymBool) -> + (SymBool, SymBool, SymBool, SymBool, SymBool) + eval = flip evalSym model + in testGroup + "(SymBool, SymBool, SymBool, SymBool, SymBool)" + [ testCase "No fill default" $ + eval + False + (ssym "a", ssym "b", ssym "c", ssym "d", ssym "e") + @?= ( con True, + ssym "b", + ssym "c", + ssym "d", + ssym "e" + ), + testCase "Fill default" $ + eval + True + (ssym "a", ssym "b", ssym "c", ssym "d", ssym "e") + @?= ( con True, + con False, + con False, + con False, + con False + ) + ] + ], + testGroup + "(,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteEvalSymOkProp + @(Integer, Integer, Integer, Integer, Integer, Integer), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + (SymBool, SymBool, SymBool, SymBool, SymBool, SymBool) -> + (SymBool, SymBool, SymBool, SymBool, SymBool, SymBool) + eval = flip evalSym model + in testGroup + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + [ testCase "No fill default" $ + eval + False + ( ssym "a", + ssym "b", + ssym "c", + ssym "d", + ssym "e", + ssym "f" + ) + @?= ( con True, + ssym "b", + ssym "c", + ssym "d", + ssym "e", + ssym "f" + ), + testCase "Fill default" $ + eval + True + ( ssym "a", + ssym "b", + ssym "c", + ssym "d", + ssym "e", + ssym "f" + ) + @?= ( con True, + con False, + con False, + con False, + con False, + con False + ) + ] + ], + testGroup + "(,,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteEvalSymOkProp + @( Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer + ), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + ( SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool + ) -> + ( SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool + ) + eval = flip evalSym model + in testGroup + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + [ testCase "No fill default" $ + eval + False + ( ssym "a", + ssym "b", + ssym "c", + ssym "d", + ssym "e", + ssym "f", + ssym "g" + ) + @?= ( con True, + ssym "b", + ssym "c", + ssym "d", + ssym "e", + ssym "f", + ssym "g" + ), + testCase "Fill default" $ + eval + True + ( ssym "a", + ssym "b", + ssym "c", + ssym "d", + ssym "e", + ssym "f", + ssym "h" + ) + @?= ( con True, + con False, + con False, + con False, + con False, + con False, + con False + ) + ] + ], + testGroup + "(,,,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteEvalSymOkProp + @( Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer + ), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + ( SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool + ) -> + ( SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool, + SymBool + ) + eval = flip evalSym model + in testGroup + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + [ testCase "No fill default" $ + eval + False + ( ssym "a", + ssym "b", + ssym "c", + ssym "d", + ssym "e", + ssym "f", + ssym "g", + ssym "h" + ) + @?= ( con True, + ssym "b", + ssym "c", + ssym "d", + ssym "e", + ssym "f", + ssym "g", + ssym "h" + ), + testCase "Fill default" $ + eval + True + ( ssym "a", + ssym "b", + ssym "c", + ssym "d", + ssym "e", + ssym "f", + ssym "h", + ssym "h" + ) + @?= ( con True, + con False, + con False, + con False, + con False, + con False, + con False, + con False + ) + ] + ], + let model = buildModel ("a" ::= True) + eval :: Bool -> B.ByteString -> B.ByteString + eval = flip evalSym model + in testGroup + "ByteString should work" + [ testGroup + "No fill default" + [ testCase "\"\"" $ + eval False ("" :: B.ByteString) @?= "", + testCase "\"a\"" $ + eval False ("a" :: B.ByteString) @?= "a" + ], + testGroup + "Fill default" + [ testCase "\"\"" $ + eval True ("" :: B.ByteString) @?= "", + testCase "\"a\"" $ + eval True ("a" :: B.ByteString) @?= "a" + ] + ], + testGroup + "Sum" + [ testProperty + "Sum Maybe Maybe Integer" + ( ioProperty . \(x :: Either (Maybe Integer) (Maybe Integer)) -> + case x of + Left val -> + concreteEvalSymOkProp + @(Sum Maybe Maybe Integer) + $ InL val + Right val -> + concreteEvalSymOkProp + @(Sum Maybe Maybe Integer) + $ InR val + ), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + Sum Maybe Maybe SymBool -> + Sum Maybe Maybe SymBool + eval = flip evalSym model + in testGroup + "Sum Maybe Maybe SymBool" + [ testGroup + "No fill default" + [ testCase "InL Nothing" $ + eval False (InL Nothing) @?= InL Nothing, + testCase "InR Nothing" $ + eval False (InR Nothing) @?= InR Nothing, + testCase "InL (Just v): v in model" $ + eval False (InL (Just $ ssym "a")) + @?= InL (Just $ con True), + testCase "InL (Just v): v not in model" $ + eval False (InL (Just $ ssym "b")) + @?= InL (Just $ ssym "b"), + testCase "InR (Just v): v in model" $ + eval False (InR (Just $ ssym "a")) + @?= InR (Just $ con True), + testCase "InR (Just v): v not in model" $ + eval False (InR (Just $ ssym "b")) + @?= InR (Just $ ssym "b") + ], + testGroup + "Fill default" + [ testCase "InL Nothing" $ + eval True (InL Nothing) @?= InL Nothing, + testCase "InR Nothing" $ + eval True (InR Nothing) @?= InR Nothing, + testCase "InL (Just v): v in model" $ + eval True (InL (Just $ ssym "a")) + @?= InL (Just $ con True), + testCase "InL (Just v): v not in model" $ + eval True (InL (Just $ ssym "b")) + @?= InL (Just $ con False), + testCase "InR (Just v): v in model" $ + eval True (InR (Just $ ssym "a")) + @?= InR (Just $ con True), + testCase "InR (Just v): v not in model" $ + eval True (InR (Just $ ssym "b")) + @?= InR (Just $ con False) + ] + ] + ], + testGroup + "WriterT" + [ testGroup + "Lazy" + [ testProperty + "WriterT Integer (Either Integer) Integer" + $ ioProperty . \(x :: Either Integer (Integer, Integer)) -> + concreteEvalSymOkProp (WriterLazy.WriterT x), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + WriterLazy.WriterT SymBool (Either SymBool) SymBool -> + WriterLazy.WriterT SymBool (Either SymBool) SymBool + eval = flip evalSym model + in testGroup + "WriterT SymBool (Either SymBool) SymBool" + [ testGroup + "No fill default" + [ testCase "WriterT (Left v): v in model" $ + eval + False + (WriterLazy.WriterT $ Left $ ssym "a") + @?= WriterLazy.WriterT (Left $ con True), + testCase "WriterT (Left v): v not in model" $ + eval + False + (WriterLazy.WriterT $ Left $ ssym "b") + @?= WriterLazy.WriterT (Left $ ssym "b"), + testCase "WriterT (Right (v1, v2))" $ + eval + False + ( WriterLazy.WriterT $ + Right (ssym "a", ssym "b") + ) + @?= WriterLazy.WriterT + (Right (con True, ssym "b")) + ], + testGroup + "Fill default" + [ testCase "WriterT (Left v): v in model" $ + eval True (WriterLazy.WriterT $ Left $ ssym "a") + @?= WriterLazy.WriterT (Left $ con True), + testCase "WriterT (Left v): v not in model" $ + eval True (WriterLazy.WriterT $ Left $ ssym "b") + @?= WriterLazy.WriterT (Left $ con False), + testCase "WriterT (Right (v1, v2))" $ + eval + True + ( WriterLazy.WriterT $ + Right (ssym "a", ssym "b") + ) + @?= WriterLazy.WriterT + (Right (con True, con False)) + ] + ] + ], + testGroup + "Strict" + [ testProperty + "WriterT Integer (Either Integer) Integer" + $ ioProperty + . \(x :: Either Integer (Integer, Integer)) -> + concreteEvalSymOkProp (WriterStrict.WriterT x), + let model = buildModel ("a" ::= True) + eval :: + Bool -> + WriterStrict.WriterT SymBool (Either SymBool) SymBool -> + WriterStrict.WriterT SymBool (Either SymBool) SymBool + eval = flip evalSym model + in testGroup + "WriterT SymBool (Either SymBool) SymBool" + [ testGroup + "No fill default" + [ testCase "WriterT (Left v): v in model" $ + eval + False + (WriterStrict.WriterT $ Left $ ssym "a") + @?= WriterStrict.WriterT (Left $ con True), + testCase "WriterT (Left v): v not in model" $ + eval + False + (WriterStrict.WriterT $ Left $ ssym "b") + @?= WriterStrict.WriterT (Left $ ssym "b"), + testCase "WriterT (Right (v1, v2))" $ + eval + False + ( WriterStrict.WriterT $ + Right (ssym "a", ssym "b") + ) + @?= WriterStrict.WriterT + (Right (con True, ssym "b")) + ], + testGroup + "Fill default" + [ testCase "WriterT (Left v): v in model" $ + eval + True + (WriterStrict.WriterT $ Left $ ssym "a") + @?= WriterStrict.WriterT (Left $ con True), + testCase "WriterT (Left v): v not in model" $ + eval + True + (WriterStrict.WriterT $ Left $ ssym "b") + @?= WriterStrict.WriterT (Left $ con False), + testCase "WriterT (Right (v1, v2))" $ + eval + True + ( WriterStrict.WriterT $ + Right (ssym "a", ssym "b") + ) + @?= WriterStrict.WriterT + (Right (con True, con False)) + ] + ] + ] + ], + testGroup + "Identity" + [ testProperty + "Identity Integer" + $ ioProperty + . \(x :: Integer) -> concreteEvalSymOkProp $ Identity x, + let model = buildModel ("a" ::= True) + eval :: Bool -> Identity SymBool -> Identity SymBool + eval = flip evalSym model + in testGroup + "Identity SymBool" + [ testGroup + "No fill default" + [ testCase "Identity v: v in model" $ + eval False (Identity $ ssym "a") + @?= Identity (con True), + testCase "Identity v: v not in model" $ + eval False (Identity $ ssym "b") + @?= Identity (ssym "b") + ], + testGroup + "Fill default" + [ testCase "Identity v: v in model" $ + eval True (Identity $ ssym "a") + @?= Identity (con True), + testCase "Identity v: v not in model" $ + eval True (Identity $ ssym "b") + @?= Identity (con False) + ] + ] + ], + testGroup + "IdentityT" + [ testProperty + "IdentityT (Either Integer) Integer" + $ ioProperty + . \(x :: Either Integer Integer) -> + concreteEvalSymOkProp $ IdentityT x, + let model = buildModel ("a" ::= True) + eval :: + Bool -> + IdentityT (Either SymBool) SymBool -> + IdentityT (Either SymBool) SymBool + eval = flip evalSym model + in testGroup + "IdentityT (Either SymBool) SymBool" + [ testGroup + "No fill default" + [ testCase "IdentityT (Left v): v in model" $ + eval False (IdentityT $ Left $ ssym "a") + @?= IdentityT (Left $ con True), + testCase "IdentityT (Left v): v not in model" $ + eval False (IdentityT $ Left $ ssym "b") + @?= IdentityT (Left $ ssym "b"), + testCase "IdentityT (Right v): v in model" $ + eval False (IdentityT $ Right $ ssym "a") + @?= IdentityT (Right $ con True), + testCase "IdentityT (Right v): v not in model" $ + eval False (IdentityT $ Right $ ssym "b") + @?= IdentityT (Right $ ssym "b") + ], + testGroup + "Fill default" + [ testCase "IdentityT (Left v): v in model" $ + eval True (IdentityT $ Left $ ssym "a") + @?= IdentityT (Left $ con True), + testCase "IdentityT (Left v): v not in model" $ + eval True (IdentityT $ Left $ ssym "b") + @?= IdentityT (Left $ con False), + testCase "IdentityT (Right v): v in model" $ + eval True (IdentityT $ Right $ ssym "a") + @?= IdentityT (Right $ con True), + testCase "IdentityT (Right v): v not in model" $ + eval True (IdentityT $ Right $ ssym "b") + @?= IdentityT (Right $ con False) + ] + ] + ] + ] + ] diff --git a/test/Grisette/Core/Data/Class/EvaluateSymTests.hs b/test/Grisette/Core/Data/Class/EvaluateSymTests.hs deleted file mode 100644 --- a/test/Grisette/Core/Data/Class/EvaluateSymTests.hs +++ /dev/null @@ -1,928 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Grisette.Core.Data.Class.EvaluateSymTests (evaluateSymTests) where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum (InL, InR)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Stack (HasCallStack) -import Grisette - ( EvaluateSym (evaluateSym), - ITEOp (symIte), - LogicalOp (symNot, (.&&), (.||)), - ModelOps (emptyModel), - ModelRep (buildModel), - ModelValuePair ((::=)), - SEq ((.==)), - Solvable (con, isym, ssym), - SymBool, - Symbol (IndexedSymbol), - TypedSymbol (TypedSymbol), - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, (@?=)) -import Test.QuickCheck (ioProperty) - -concreteEvaluateSymOkProp :: - (HasCallStack, EvaluateSym a, Show a, Eq a) => a -> Assertion -concreteEvaluateSymOkProp x = evaluateSym True emptyModel x @?= x - -evaluateSymTests :: Test -evaluateSymTests = - testGroup - "EvaluateSym" - [ testGroup - "EvaluateSym for common types" - [ testGroup - "SymBool" - [ let model = emptyModel - eval :: SymBool -> SymBool - eval = evaluateSym False model - in testGroup - "Empty model / no fill default" - [ testCase "con" $ - eval (con True) @?= con True, - testCase "ssym" $ - eval (ssym "a") @?= ssym "a", - testCase "isym" $ - eval (isym "a" 1) @?= isym "a" 1, - testCase ".||" $ - eval (ssym "a" .|| ssym "b") - @?= ssym "a" - .|| ssym "b", - testCase ".&&" $ - eval (ssym "a" .&& ssym "b") - @?= ssym "a" - .&& ssym "b", - testCase ".==" $ - eval ((ssym "a" :: SymBool) .== ssym "b") - @?= (ssym "a" :: SymBool) - .== ssym "b", - testCase "symNot" $ - eval (symNot (ssym "a")) - @?= symNot (ssym "a"), - testCase "symIte" $ - eval (symIte (ssym "a") (ssym "b") (ssym "c")) - @?= symIte (ssym "a") (ssym "b") (ssym "c") - ], - let model = emptyModel - eval :: SymBool -> SymBool - eval = evaluateSym True model - in testGroup - "Empty model / with fill default" - [ testCase "con" $ - eval (con True) @?= con True, - testCase "ssym" $ - eval (ssym "a") @?= con False, - testCase "isym" $ - eval (isym "a" 1) @?= con False, - testCase ".||" $ - eval (ssym "a" .|| ssym "b") @?= con False, - testCase ".&&" $ - eval (ssym "a" .&& ssym "b") @?= con False, - testCase ".==" $ - eval ((ssym "a" :: SymBool) .== ssym "b") @?= con True, - testCase "symNot" $ - eval (symNot (ssym "a")) @?= con True, - testCase "symIte" $ - eval (symIte (ssym "a") (ssym "b") (ssym "c")) - @?= con False - ], - let model = - buildModel - ( "a" ::= True, - TypedSymbol (IndexedSymbol "a" 1) ::= False, - "b" ::= False, - "c" ::= True - ) - eval :: SymBool -> SymBool - eval = evaluateSym True model - in testGroup - "Some model" - [ testCase "con" $ - eval (con True) @?= con True, - testCase "ssym" $ - eval (ssym "a") @?= con True, - testCase "isym" $ - eval (isym "a" 1) @?= con False, - testCase ".||" $ - eval (ssym "a" .|| ssym "b") @?= con True, - testCase ".&&" $ - eval (ssym "a" .&& ssym "b") @?= con False, - testCase ".==" $ - eval ((ssym "a" :: SymBool) .== ssym "b") @?= con False, - testCase "symNot" $ - eval (symNot (ssym "a")) @?= con False, - testCase "symIte" $ - eval (symIte (ssym "a") (ssym "b") (ssym "c")) - @?= con False - ] - ], - testProperty "Bool" $ ioProperty . concreteEvaluateSymOkProp @Bool, - testProperty "Integer" $ - ioProperty . concreteEvaluateSymOkProp @Integer, - testProperty "Char" $ ioProperty . concreteEvaluateSymOkProp @Char, - testProperty "Int" $ ioProperty . concreteEvaluateSymOkProp @Int, - testProperty "Int8" $ ioProperty . concreteEvaluateSymOkProp @Int8, - testProperty "Int16" $ ioProperty . concreteEvaluateSymOkProp @Int16, - testProperty "Int32" $ ioProperty . concreteEvaluateSymOkProp @Int32, - testProperty "Int64" $ ioProperty . concreteEvaluateSymOkProp @Int64, - testProperty "Word" $ ioProperty . concreteEvaluateSymOkProp @Word, - testProperty "Word8" $ ioProperty . concreteEvaluateSymOkProp @Word8, - testProperty "Word16" $ - ioProperty . concreteEvaluateSymOkProp @Word16, - testProperty "Word32" $ - ioProperty . concreteEvaluateSymOkProp @Word32, - testProperty "Word64" $ - ioProperty . concreteEvaluateSymOkProp @Word64, - testGroup - "List" - [ testProperty "[Integer]" $ - ioProperty . concreteEvaluateSymOkProp @[Integer], - let model = - buildModel ("a" ::= True, "b" ::= False) - eval :: Bool -> [SymBool] -> [SymBool] - eval = flip evaluateSym model - in testGroup - "[SymBool]" - [ testGroup - "No fill default" - [ testCase "Empty list" $ - eval False [] @?= [], - testCase "Non-empty list" $ - eval False [ssym "a", ssym "b", ssym "c"] - @?= [con True, con False, ssym "c"] - ], - testGroup - "Fill default" - [ testCase "Empty list" $ - eval True [] @?= [], - testCase "Non-empty list" $ - eval True [ssym "a", ssym "b", ssym "c"] - @?= [con True, con False, con False] - ] - ] - ], - testGroup - "Maybe" - [ testProperty "Maybe Integer" $ - ioProperty . concreteEvaluateSymOkProp @(Maybe Integer), - let model = buildModel ("a" ::= True) - eval :: Bool -> Maybe SymBool -> Maybe SymBool - eval = flip evaluateSym model - in testGroup - "Maybe SymBool" - [ testGroup - "No fill default" - [ testCase "Nothing" $ - eval False Nothing @?= Nothing, - testCase "Just v: v in model" $ - eval False (Just (ssym "a")) @?= Just (con True), - testCase "Just v: v not in model" $ - eval False (Just (ssym "b")) @?= Just (ssym "b") - ], - testGroup - "Fill default" - [ testCase "Nothing" $ - eval True (Nothing) @?= Nothing, - testCase "Just v: v in model" $ - eval True (Just (ssym "a")) @?= Just (con True), - testCase "Just v: v not in model" $ - eval True (Just (ssym "b")) @?= Just (con False) - ] - ] - ], - testGroup - "Either" - [ testProperty "Either Integer Integer" $ - ioProperty - . concreteEvaluateSymOkProp @(Either Integer Integer), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - Either SymBool SymBool -> - Either SymBool SymBool - eval = flip evaluateSym model - in testGroup - "Either SymBool SymBool" - [ testGroup - "No fill default" - [ testCase "Left v: v in model" $ - eval False (Left (ssym "a")) @?= Left (con True), - testCase "Left v: v not in model" $ - eval False (Left (ssym "b")) @?= Left (ssym "b"), - testCase "Right v: v in model" $ - eval False (Right (ssym "a")) @?= Right (con True), - testCase "Right v: v not in model" $ - eval False (Right (ssym "b")) @?= Right (ssym "b") - ], - testGroup - "Fill default" - [ testCase "Left v: v in model" $ - eval True (Left (ssym "a")) @?= Left (con True), - testCase "Left v: v not in model" $ - eval True (Left (ssym "b")) @?= Left (con False), - testCase "Right v: v in model" $ - eval True (Right (ssym "a")) @?= Right (con True), - testCase "Right v: v not in model" $ - eval True (Right (ssym "b")) @?= Right (con False) - ] - ] - ], - testGroup - "MaybeT" - [ testProperty "MaybeT Maybe Integer" $ - ioProperty - . concreteEvaluateSymOkProp @(MaybeT Maybe Integer) - . MaybeT, - let model = buildModel ("a" ::= True) - eval :: - Bool -> - MaybeT Maybe SymBool -> - MaybeT Maybe SymBool - eval = flip evaluateSym model - in testGroup - "MaybeT should work" - [ testGroup - "No fill default" - [ testCase "MaybeT Nothing" $ - eval False (MaybeT Nothing) @?= MaybeT Nothing, - testCase "MaybeT (Just Nothing)" $ - eval False (MaybeT $ Just Nothing) - @?= MaybeT (Just Nothing), - testCase "MaybeT (Just v): v in model" $ - eval False (MaybeT $ Just $ Just (ssym "a")) - @?= MaybeT (Just (Just (con True))), - testCase "MaybeT (Just v): v not in model" $ - eval False (MaybeT $ Just $ Just (ssym "b")) - @?= MaybeT (Just (Just (ssym "b"))) - ], - testGroup - "Fill default" - [ testCase "MaybeT Nothing" $ - eval True (MaybeT Nothing) @?= MaybeT Nothing, - testCase "MaybeT (Just Nothing)" $ - eval True (MaybeT $ Just Nothing) - @?= MaybeT (Just Nothing), - testCase "MaybeT (Just v): v in model" $ - eval True (MaybeT $ Just $ Just (ssym "a")) - @?= MaybeT (Just (Just (con True))), - testCase "MaybeT (Just v): v not in model" $ - eval True (MaybeT $ Just $ Just (ssym "b")) - @?= MaybeT (Just (Just (con False))) - ] - ] - ], - testGroup - "ExceptT" - [ testProperty "ExceptT Integer Maybe Integer" $ - ioProperty - . concreteEvaluateSymOkProp @(ExceptT Integer Maybe Integer) - . ExceptT, - let model = buildModel ("a" ::= True) - eval :: - Bool -> - ExceptT SymBool Maybe SymBool -> - ExceptT SymBool Maybe SymBool - eval = flip evaluateSym model - in testGroup - "ExceptT SymBool Maybe SymBool" - [ testGroup - "No fill default" - [ testCase "ExceptT Nothing" $ - eval False (ExceptT Nothing) @?= ExceptT Nothing, - testCase "ExceptT (Just (Left v)): v in model" $ - eval False (ExceptT $ Just $ Left $ ssym "a") - @?= ExceptT (Just $ Left $ con True), - testCase "ExceptT (Just (Left v)): v not in model" $ - eval False (ExceptT $ Just $ Left $ ssym "b") - @?= ExceptT (Just $ Left $ ssym "b"), - testCase "ExceptT (Just (Right v)): v in model" $ - eval False (ExceptT $ Just $ Right $ ssym "a") - @?= ExceptT (Just $ Right $ con True), - testCase "ExceptT (Just (Right v)): v not in model" $ - eval False (ExceptT $ Just $ Right $ ssym "b") - @?= ExceptT (Just $ Right $ ssym "b") - ], - testGroup - "Fill default" - [ testCase "ExceptT Nothing" $ - eval True (ExceptT Nothing) @?= ExceptT Nothing, - testCase "ExceptT (Just (Left v)): v in model" $ - eval True (ExceptT $ Just $ Left $ ssym "a") - @?= ExceptT (Just $ Left $ con True), - testCase "ExceptT (Just (Left v)): v not in model" $ - eval True (ExceptT $ Just $ Left $ ssym "b") - @?= ExceptT (Just $ Left $ con False), - testCase "ExceptT (Just (Right v)): v in model" $ - eval True (ExceptT $ Just $ Right $ ssym "a") - @?= ExceptT (Just $ Right $ con True), - testCase "ExceptT (Just (Right v)): v not in model" $ - eval True (ExceptT $ Just $ Right $ ssym "b") - @?= ExceptT (Just $ Right $ con False) - ] - ] - ], - testProperty "()" (ioProperty . concreteEvaluateSymOkProp @()), - testGroup - "(,)" - [ testProperty "(Integer, Integer)" $ - ioProperty . concreteEvaluateSymOkProp @(Integer, Integer), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - (SymBool, SymBool) -> - (SymBool, SymBool) - eval = flip evaluateSym model - in testGroup - "(SymBool, SymBool)" - [ testCase "No fill default" $ - eval False (ssym "a", ssym "b") - @?= (con True, ssym "b"), - testCase "Fill default" $ - eval True (ssym "a", ssym "b") - @?= (con True, con False) - ] - ], - testGroup - "(,,)" - [ testProperty "(Integer, Integer, Integer)" $ - ioProperty - . concreteEvaluateSymOkProp @(Integer, Integer, Integer), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - (SymBool, SymBool, SymBool) -> - (SymBool, SymBool, SymBool) - eval = flip evaluateSym model - in testGroup - "(SymBool, SymBool, SymBool)" - [ testCase "No fill default" $ - eval False (ssym "a", ssym "b", ssym "c") - @?= (con True, ssym "b", ssym "c"), - testCase "Fill default" $ - eval True (ssym "a", ssym "b", ssym "c") - @?= (con True, con False, con False) - ] - ], - testGroup - "(,,,)" - [ testProperty "(Integer, Integer, Integer, Integer)" $ - ioProperty - . concreteEvaluateSymOkProp - @(Integer, Integer, Integer, Integer), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - (SymBool, SymBool, SymBool, SymBool) -> - (SymBool, SymBool, SymBool, SymBool) - eval = flip evaluateSym model - in testGroup - "(SymBool, SymBool, SymBool, SymBool)" - [ testCase "No fill default" $ - eval False (ssym "a", ssym "b", ssym "c", ssym "d") - @?= (con True, ssym "b", ssym "c", ssym "d"), - testCase "Fill default" $ - eval True (ssym "a", ssym "b", ssym "c", ssym "d") - @?= (con True, con False, con False, con False) - ] - ], - testGroup - "(,,,,)" - [ testProperty "(Integer, Integer, Integer, Integer, Integer)" $ - ioProperty - . concreteEvaluateSymOkProp - @(Integer, Integer, Integer, Integer, Integer), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - (SymBool, SymBool, SymBool, SymBool, SymBool) -> - (SymBool, SymBool, SymBool, SymBool, SymBool) - eval = flip evaluateSym model - in testGroup - "(SymBool, SymBool, SymBool, SymBool, SymBool)" - [ testCase "No fill default" $ - eval - False - (ssym "a", ssym "b", ssym "c", ssym "d", ssym "e") - @?= ( con True, - ssym "b", - ssym "c", - ssym "d", - ssym "e" - ), - testCase "Fill default" $ - eval - True - (ssym "a", ssym "b", ssym "c", ssym "d", ssym "e") - @?= ( con True, - con False, - con False, - con False, - con False - ) - ] - ], - testGroup - "(,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteEvaluateSymOkProp - @(Integer, Integer, Integer, Integer, Integer, Integer), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - (SymBool, SymBool, SymBool, SymBool, SymBool, SymBool) -> - (SymBool, SymBool, SymBool, SymBool, SymBool, SymBool) - eval = flip evaluateSym model - in testGroup - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - [ testCase "No fill default" $ - eval - False - ( ssym "a", - ssym "b", - ssym "c", - ssym "d", - ssym "e", - ssym "f" - ) - @?= ( con True, - ssym "b", - ssym "c", - ssym "d", - ssym "e", - ssym "f" - ), - testCase "Fill default" $ - eval - True - ( ssym "a", - ssym "b", - ssym "c", - ssym "d", - ssym "e", - ssym "f" - ) - @?= ( con True, - con False, - con False, - con False, - con False, - con False - ) - ] - ], - testGroup - "(,,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteEvaluateSymOkProp - @( Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer - ), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - ( SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool - ) -> - ( SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool - ) - eval = flip evaluateSym model - in testGroup - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - [ testCase "No fill default" $ - eval - False - ( ssym "a", - ssym "b", - ssym "c", - ssym "d", - ssym "e", - ssym "f", - ssym "g" - ) - @?= ( con True, - ssym "b", - ssym "c", - ssym "d", - ssym "e", - ssym "f", - ssym "g" - ), - testCase "Fill default" $ - eval - True - ( ssym "a", - ssym "b", - ssym "c", - ssym "d", - ssym "e", - ssym "f", - ssym "h" - ) - @?= ( con True, - con False, - con False, - con False, - con False, - con False, - con False - ) - ] - ], - testGroup - "(,,,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteEvaluateSymOkProp - @( Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer - ), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - ( SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool - ) -> - ( SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool, - SymBool - ) - eval = flip evaluateSym model - in testGroup - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - [ testCase "No fill default" $ - eval - False - ( ssym "a", - ssym "b", - ssym "c", - ssym "d", - ssym "e", - ssym "f", - ssym "g", - ssym "h" - ) - @?= ( con True, - ssym "b", - ssym "c", - ssym "d", - ssym "e", - ssym "f", - ssym "g", - ssym "h" - ), - testCase "Fill default" $ - eval - True - ( ssym "a", - ssym "b", - ssym "c", - ssym "d", - ssym "e", - ssym "f", - ssym "h", - ssym "h" - ) - @?= ( con True, - con False, - con False, - con False, - con False, - con False, - con False, - con False - ) - ] - ], - let model = buildModel ("a" ::= True) - eval :: Bool -> B.ByteString -> B.ByteString - eval = flip evaluateSym model - in testGroup - "ByteString should work" - [ testGroup - "No fill default" - [ testCase "\"\"" $ - eval False ("" :: B.ByteString) @?= "", - testCase "\"a\"" $ - eval False ("a" :: B.ByteString) @?= "a" - ], - testGroup - "Fill default" - [ testCase "\"\"" $ - eval True ("" :: B.ByteString) @?= "", - testCase "\"a\"" $ - eval True ("a" :: B.ByteString) @?= "a" - ] - ], - testGroup - "Sum" - [ testProperty - "Sum Maybe Maybe Integer" - ( ioProperty . \(x :: Either (Maybe Integer) (Maybe Integer)) -> - case x of - Left val -> - concreteEvaluateSymOkProp - @(Sum Maybe Maybe Integer) - $ InL val - Right val -> - concreteEvaluateSymOkProp - @(Sum Maybe Maybe Integer) - $ InR val - ), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - Sum Maybe Maybe SymBool -> - Sum Maybe Maybe SymBool - eval = flip evaluateSym model - in testGroup - "Sum Maybe Maybe SymBool" - [ testGroup - "No fill default" - [ testCase "InL Nothing" $ - eval False (InL Nothing) @?= InL Nothing, - testCase "InR Nothing" $ - eval False (InR Nothing) @?= InR Nothing, - testCase "InL (Just v): v in model" $ - eval False (InL (Just $ ssym "a")) - @?= InL (Just $ con True), - testCase "InL (Just v): v not in model" $ - eval False (InL (Just $ ssym "b")) - @?= InL (Just $ ssym "b"), - testCase "InR (Just v): v in model" $ - eval False (InR (Just $ ssym "a")) - @?= InR (Just $ con True), - testCase "InR (Just v): v not in model" $ - eval False (InR (Just $ ssym "b")) - @?= InR (Just $ ssym "b") - ], - testGroup - "Fill default" - [ testCase "InL Nothing" $ - eval True (InL Nothing) @?= InL Nothing, - testCase "InR Nothing" $ - eval True (InR Nothing) @?= InR Nothing, - testCase "InL (Just v): v in model" $ - eval True (InL (Just $ ssym "a")) - @?= InL (Just $ con True), - testCase "InL (Just v): v not in model" $ - eval True (InL (Just $ ssym "b")) - @?= InL (Just $ con False), - testCase "InR (Just v): v in model" $ - eval True (InR (Just $ ssym "a")) - @?= InR (Just $ con True), - testCase "InR (Just v): v not in model" $ - eval True (InR (Just $ ssym "b")) - @?= InR (Just $ con False) - ] - ] - ], - testGroup - "WriterT" - [ testGroup - "Lazy" - [ testProperty - "WriterT Integer (Either Integer) Integer" - $ ioProperty . \(x :: Either Integer (Integer, Integer)) -> - concreteEvaluateSymOkProp (WriterLazy.WriterT x), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - WriterLazy.WriterT SymBool (Either SymBool) SymBool -> - WriterLazy.WriterT SymBool (Either SymBool) SymBool - eval = flip evaluateSym model - in testGroup - "WriterT SymBool (Either SymBool) SymBool" - [ testGroup - "No fill default" - [ testCase "WriterT (Left v): v in model" $ - eval - False - (WriterLazy.WriterT $ Left $ ssym "a") - @?= WriterLazy.WriterT (Left $ con True), - testCase "WriterT (Left v): v not in model" $ - eval - False - (WriterLazy.WriterT $ Left $ ssym "b") - @?= WriterLazy.WriterT (Left $ ssym "b"), - testCase "WriterT (Right (v1, v2))" $ - eval - False - ( WriterLazy.WriterT $ - Right (ssym "a", ssym "b") - ) - @?= WriterLazy.WriterT - (Right (con True, ssym "b")) - ], - testGroup - "Fill default" - [ testCase "WriterT (Left v): v in model" $ - eval True (WriterLazy.WriterT $ Left $ ssym "a") - @?= WriterLazy.WriterT (Left $ con True), - testCase "WriterT (Left v): v not in model" $ - eval True (WriterLazy.WriterT $ Left $ ssym "b") - @?= WriterLazy.WriterT (Left $ con False), - testCase "WriterT (Right (v1, v2))" $ - eval - True - ( WriterLazy.WriterT $ - Right (ssym "a", ssym "b") - ) - @?= WriterLazy.WriterT - (Right (con True, con False)) - ] - ] - ], - testGroup - "Strict" - [ testProperty - "WriterT Integer (Either Integer) Integer" - $ ioProperty - . \(x :: Either Integer (Integer, Integer)) -> - concreteEvaluateSymOkProp (WriterStrict.WriterT x), - let model = buildModel ("a" ::= True) - eval :: - Bool -> - WriterStrict.WriterT SymBool (Either SymBool) SymBool -> - WriterStrict.WriterT SymBool (Either SymBool) SymBool - eval = flip evaluateSym model - in testGroup - "WriterT SymBool (Either SymBool) SymBool" - [ testGroup - "No fill default" - [ testCase "WriterT (Left v): v in model" $ - eval - False - (WriterStrict.WriterT $ Left $ ssym "a") - @?= WriterStrict.WriterT (Left $ con True), - testCase "WriterT (Left v): v not in model" $ - eval - False - (WriterStrict.WriterT $ Left $ ssym "b") - @?= WriterStrict.WriterT (Left $ ssym "b"), - testCase "WriterT (Right (v1, v2))" $ - eval - False - ( WriterStrict.WriterT $ - Right (ssym "a", ssym "b") - ) - @?= WriterStrict.WriterT - (Right (con True, ssym "b")) - ], - testGroup - "Fill default" - [ testCase "WriterT (Left v): v in model" $ - eval - True - (WriterStrict.WriterT $ Left $ ssym "a") - @?= WriterStrict.WriterT (Left $ con True), - testCase "WriterT (Left v): v not in model" $ - eval - True - (WriterStrict.WriterT $ Left $ ssym "b") - @?= WriterStrict.WriterT (Left $ con False), - testCase "WriterT (Right (v1, v2))" $ - eval - True - ( WriterStrict.WriterT $ - Right (ssym "a", ssym "b") - ) - @?= WriterStrict.WriterT - (Right (con True, con False)) - ] - ] - ] - ], - testGroup - "Identity" - [ testProperty - "Identity Integer" - $ ioProperty - . \(x :: Integer) -> concreteEvaluateSymOkProp $ Identity x, - let model = buildModel ("a" ::= True) - eval :: Bool -> Identity SymBool -> Identity SymBool - eval = flip evaluateSym model - in testGroup - "Identity SymBool" - [ testGroup - "No fill default" - [ testCase "Identity v: v in model" $ - eval False (Identity $ ssym "a") - @?= Identity (con True), - testCase "Identity v: v not in model" $ - eval False (Identity $ ssym "b") - @?= Identity (ssym "b") - ], - testGroup - "Fill default" - [ testCase "Identity v: v in model" $ - eval True (Identity $ ssym "a") - @?= Identity (con True), - testCase "Identity v: v not in model" $ - eval True (Identity $ ssym "b") - @?= Identity (con False) - ] - ] - ], - testGroup - "IdentityT" - [ testProperty - "IdentityT (Either Integer) Integer" - $ ioProperty - . \(x :: Either Integer Integer) -> - concreteEvaluateSymOkProp $ IdentityT x, - let model = buildModel ("a" ::= True) - eval :: - Bool -> - IdentityT (Either SymBool) SymBool -> - IdentityT (Either SymBool) SymBool - eval = flip evaluateSym model - in testGroup - "IdentityT (Either SymBool) SymBool" - [ testGroup - "No fill default" - [ testCase "IdentityT (Left v): v in model" $ - eval False (IdentityT $ Left $ ssym "a") - @?= IdentityT (Left $ con True), - testCase "IdentityT (Left v): v not in model" $ - eval False (IdentityT $ Left $ ssym "b") - @?= IdentityT (Left $ ssym "b"), - testCase "IdentityT (Right v): v in model" $ - eval False (IdentityT $ Right $ ssym "a") - @?= IdentityT (Right $ con True), - testCase "IdentityT (Right v): v not in model" $ - eval False (IdentityT $ Right $ ssym "b") - @?= IdentityT (Right $ ssym "b") - ], - testGroup - "Fill default" - [ testCase "IdentityT (Left v): v in model" $ - eval True (IdentityT $ Left $ ssym "a") - @?= IdentityT (Left $ con True), - testCase "IdentityT (Left v): v not in model" $ - eval True (IdentityT $ Left $ ssym "b") - @?= IdentityT (Left $ con False), - testCase "IdentityT (Right v): v in model" $ - eval True (IdentityT $ Right $ ssym "a") - @?= IdentityT (Right $ con True), - testCase "IdentityT (Right v): v not in model" $ - eval True (IdentityT $ Right $ ssym "b") - @?= IdentityT (Right $ con False) - ] - ] - ] - ] - ] diff --git a/test/Grisette/Core/Data/Class/ExtractSymTests.hs b/test/Grisette/Core/Data/Class/ExtractSymTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/ExtractSymTests.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Core.Data.Class.ExtractSymTests + ( extractSymTests, + ) +where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics (Generic) +import GHC.Stack (HasCallStack) +import Generics.Deriving (Default (Default)) +import Grisette + ( ExtractSym (extractSym), + ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + SymBool, + SymEq ((.==)), + SymbolSetOps (emptySet), + SymbolSetRep (buildSymbolSet), + ) +import Grisette.Core.Data.Class.TestValues + ( isymBool, + isymbolBool, + ssymBool, + ssymbolBool, + symTrue, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, (@?=)) +import Test.QuickCheck (ioProperty) + +data A = A1 | A2 SymBool | A3 SymBool SymBool + deriving (Generic, Show, Eq) + deriving (ExtractSym) via (Default A) + +concreteExtractSymOkProp :: + (HasCallStack, ExtractSym a) => (a, a) -> Assertion +concreteExtractSymOkProp x = extractSym x @?= emptySet + +extractSymTests :: Test +extractSymTests = + testGroup + "ExtractSym" + [ testGroup + "Common types" + [ testGroup + "SymBool" + [ testCase "con" $ + extractSym symTrue @?= emptySet, + testCase "ssym" $ + extractSym (ssymBool "a") + @?= buildSymbolSet (ssymbolBool "a"), + testCase "isym" $ + extractSym (isymBool "a" 1) + @?= buildSymbolSet (isymbolBool "a" 1), + testCase "And" $ + extractSym (ssymBool "a" .&& isymBool "b" 1) + @?= buildSymbolSet (ssymbolBool "a", isymbolBool "b" 1), + testCase "Or" $ + extractSym (ssymBool "a" .|| isymBool "b" 1) + @?= buildSymbolSet (ssymbolBool "a", isymbolBool "b" 1), + testCase "Equal" $ + extractSym (ssymBool "a" .== isymBool "b" 1) + @?= buildSymbolSet (ssymbolBool "a", isymbolBool "b" 1), + testCase "ITE" $ + extractSym + (symIte (ssymBool "a") (isymBool "b" 1) (ssymBool "c")) + @?= buildSymbolSet + ( ssymbolBool "a", + isymbolBool "b" 1, + ssymbolBool "c" + ), + testCase "Not" $ + extractSym (symNot $ isymBool "a" 1) + @?= buildSymbolSet (isymbolBool "a" 1) + ], + testProperty "Bool" $ + ioProperty . concreteExtractSymOkProp @Bool, + testProperty "Integer" $ + ioProperty . concreteExtractSymOkProp @Integer, + testProperty "Char" $ + ioProperty . concreteExtractSymOkProp @Char, + testProperty "Int" $ ioProperty . concreteExtractSymOkProp @Int, + testProperty "Int8" $ + ioProperty . concreteExtractSymOkProp @Int8, + testProperty "Int16" $ + ioProperty . concreteExtractSymOkProp @Int16, + testProperty "Int32" $ + ioProperty . concreteExtractSymOkProp @Int32, + testProperty "Int64" $ + ioProperty . concreteExtractSymOkProp @Int64, + testProperty "Word" $ + ioProperty . concreteExtractSymOkProp @Word, + testProperty "Word8" $ + ioProperty . concreteExtractSymOkProp @Word8, + testProperty "Word16" $ + ioProperty . concreteExtractSymOkProp @Word16, + testProperty "Word32" $ + ioProperty . concreteExtractSymOkProp @Word32, + testProperty "Word64" $ + ioProperty . concreteExtractSymOkProp @Word64, + testGroup + "[SymBool]" + [ testCase "[]" $ + extractSym ([] :: [SymBool]) @?= emptySet, + testCase "[v]" $ + extractSym [ssymBool "a"] + @?= buildSymbolSet (ssymbolBool "a"), + testCase "[v1, v2]" $ + extractSym [ssymBool "a", ssymBool "b"] + @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b") + ], + testGroup + "Maybe SymBool" + [ testCase "Nothing" $ + extractSym (Nothing :: Maybe SymBool) @?= emptySet, + testCase "Just v" $ + extractSym (Just (ssymBool "a")) + @?= buildSymbolSet (ssymbolBool "a") + ], + testGroup + "Either SymBool SymBool" + [ testCase "Left v" $ + extractSym + (Left (ssymBool "a") :: Either SymBool SymBool) + @?= buildSymbolSet (ssymbolBool "a"), + testCase "Right v" $ + extractSym + (Right (ssymBool "a") :: Either SymBool SymBool) + @?= buildSymbolSet (ssymbolBool "a") + ], + testGroup + "MaybeT Maybe SymBool" + [ testCase "MaybeT Nothing" $ + extractSym (MaybeT Nothing :: MaybeT Maybe SymBool) + @?= emptySet, + testCase "MaybeT (Just Nothing)" $ + extractSym (MaybeT (Just Nothing) :: MaybeT Maybe SymBool) + @?= emptySet, + testCase "MaybeT (Just (Just v))" $ + extractSym (MaybeT (Just (Just (ssymBool "a")))) + @?= buildSymbolSet (ssymbolBool "a") + ], + testGroup + "ExceptT SymBool Maybe SymBool" + [ testCase "ExceptT Nothing" $ + extractSym + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + @?= emptySet, + testCase "ExceptT (Just (Left v))" $ + extractSym + ( ExceptT (Just (Left (ssymBool "a"))) :: + ExceptT SymBool Maybe SymBool + ) + @?= buildSymbolSet (ssymbolBool "a"), + testCase "ExceptT (Just (Right v))" $ + extractSym + ( ExceptT (Just (Right (ssymBool "a"))) :: + ExceptT SymBool Maybe SymBool + ) + @?= buildSymbolSet (ssymbolBool "a") + ], + testGroup + "WriterT SymBool Maybe SymBool" + [ testGroup + "Lazy" + [ testCase "WriterT Nothing" $ + extractSym + ( WriterLazy.WriterT Nothing :: + WriterLazy.WriterT SymBool Maybe SymBool + ) + @?= emptySet, + testCase "WriterT (Just (v1, v2))" $ + extractSym + ( WriterLazy.WriterT + (Just (ssymBool "a", ssymBool "b")) :: + WriterLazy.WriterT SymBool Maybe SymBool + ) + @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b") + ], + testGroup + "Strict" + [ testCase "WriterT Nothing" $ + extractSym + ( WriterStrict.WriterT Nothing :: + WriterStrict.WriterT SymBool Maybe SymBool + ) + @?= emptySet, + testCase "WriterT (Just (v1, v2))" $ + extractSym + ( WriterStrict.WriterT + (Just (ssymBool "a", ssymBool "b")) :: + WriterStrict.WriterT SymBool Maybe SymBool + ) + @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b") + ] + ], + testProperty "()" (ioProperty . concreteExtractSymOkProp @()), + testCase "(,)" $ + extractSym (ssymBool "a", ssymBool "b") + @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b"), + testCase "(,,)" $ + extractSym (ssymBool "a", ssymBool "b", ssymBool "c") + @?= buildSymbolSet + (ssymbolBool "a", ssymbolBool "b", ssymbolBool "c"), + testGroup + "ByteString" + [ testCase "\"\"" $ + extractSym ("" :: B.ByteString) @?= emptySet, + testCase "\"a\"" $ + extractSym ("a" :: B.ByteString) @?= emptySet + ], + testCase "Identity SymBool" $ + extractSym (Identity (ssymBool "a")) + @?= buildSymbolSet (ssymbolBool "a"), + testGroup + "IdentityT (Either SymBool) SymBool" + [ testCase "Identity (Left v)" $ + extractSym + ( IdentityT $ Left (ssymBool "a") :: + IdentityT (Either SymBool) SymBool + ) + @?= buildSymbolSet (ssymbolBool "a"), + testCase "Identity (Right v)" $ + extractSym + ( IdentityT $ Right (ssymBool "a") :: + IdentityT (Either SymBool) SymBool + ) + @?= buildSymbolSet (ssymbolBool "a") + ] + ], + testGroup + "deriving ExtractSym for ADT" + [ testGroup + "Simple ADT" + [ testCase "A1" $ + extractSym A1 @?= emptySet, + testCase "A2" $ + extractSym (A2 (ssymBool "a")) + @?= buildSymbolSet (ssymbolBool "a"), + testCase "A3" $ + extractSym (A3 (ssymBool "a") (ssymBool "b")) + @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b") + ] + ] + ] diff --git a/test/Grisette/Core/Data/Class/ExtractSymbolicsTests.hs b/test/Grisette/Core/Data/Class/ExtractSymbolicsTests.hs deleted file mode 100644 --- a/test/Grisette/Core/Data/Class/ExtractSymbolicsTests.hs +++ /dev/null @@ -1,262 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Grisette.Core.Data.Class.ExtractSymbolicsTests - ( extractSymbolicsTests, - ) -where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics (Generic) -import GHC.Stack (HasCallStack) -import Generics.Deriving (Default (Default)) -import Grisette - ( ExtractSymbolics (extractSymbolics), - ITEOp (symIte), - LogicalOp (symNot, (.&&), (.||)), - SEq ((.==)), - SymBool, - SymbolSetOps (emptySet), - SymbolSetRep (buildSymbolSet), - ) -import Grisette.Core.Data.Class.TestValues - ( isymBool, - isymbolBool, - ssymBool, - ssymbolBool, - symTrue, - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, (@?=)) -import Test.QuickCheck (ioProperty) - -data A = A1 | A2 SymBool | A3 SymBool SymBool - deriving (Generic, Show, Eq) - deriving (ExtractSymbolics) via (Default A) - -concreteExtractSymbolicsOkProp :: - (HasCallStack, ExtractSymbolics a) => (a, a) -> Assertion -concreteExtractSymbolicsOkProp x = extractSymbolics x @?= emptySet - -extractSymbolicsTests :: Test -extractSymbolicsTests = - testGroup - "ExtractSymbolics" - [ testGroup - "Common types" - [ testGroup - "SymBool" - [ testCase "con" $ - extractSymbolics symTrue @?= emptySet, - testCase "ssym" $ - extractSymbolics (ssymBool "a") - @?= buildSymbolSet (ssymbolBool "a"), - testCase "isym" $ - extractSymbolics (isymBool "a" 1) - @?= buildSymbolSet (isymbolBool "a" 1), - testCase "And" $ - extractSymbolics (ssymBool "a" .&& isymBool "b" 1) - @?= buildSymbolSet (ssymbolBool "a", isymbolBool "b" 1), - testCase "Or" $ - extractSymbolics (ssymBool "a" .|| isymBool "b" 1) - @?= buildSymbolSet (ssymbolBool "a", isymbolBool "b" 1), - testCase "Equal" $ - extractSymbolics (ssymBool "a" .== isymBool "b" 1) - @?= buildSymbolSet (ssymbolBool "a", isymbolBool "b" 1), - testCase "ITE" $ - extractSymbolics - (symIte (ssymBool "a") (isymBool "b" 1) (ssymBool "c")) - @?= buildSymbolSet - ( ssymbolBool "a", - isymbolBool "b" 1, - ssymbolBool "c" - ), - testCase "Not" $ - extractSymbolics (symNot $ isymBool "a" 1) - @?= buildSymbolSet (isymbolBool "a" 1) - ], - testProperty "Bool" $ - ioProperty . concreteExtractSymbolicsOkProp @Bool, - testProperty "Integer" $ - ioProperty . concreteExtractSymbolicsOkProp @Integer, - testProperty "Char" $ - ioProperty . concreteExtractSymbolicsOkProp @Char, - testProperty "Int" $ ioProperty . concreteExtractSymbolicsOkProp @Int, - testProperty "Int8" $ - ioProperty . concreteExtractSymbolicsOkProp @Int8, - testProperty "Int16" $ - ioProperty . concreteExtractSymbolicsOkProp @Int16, - testProperty "Int32" $ - ioProperty . concreteExtractSymbolicsOkProp @Int32, - testProperty "Int64" $ - ioProperty . concreteExtractSymbolicsOkProp @Int64, - testProperty "Word" $ - ioProperty . concreteExtractSymbolicsOkProp @Word, - testProperty "Word8" $ - ioProperty . concreteExtractSymbolicsOkProp @Word8, - testProperty "Word16" $ - ioProperty . concreteExtractSymbolicsOkProp @Word16, - testProperty "Word32" $ - ioProperty . concreteExtractSymbolicsOkProp @Word32, - testProperty "Word64" $ - ioProperty . concreteExtractSymbolicsOkProp @Word64, - testGroup - "[SymBool]" - [ testCase "[]" $ - extractSymbolics ([] :: [SymBool]) @?= emptySet, - testCase "[v]" $ - extractSymbolics [ssymBool "a"] - @?= buildSymbolSet (ssymbolBool "a"), - testCase "[v1, v2]" $ - extractSymbolics [ssymBool "a", ssymBool "b"] - @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b") - ], - testGroup - "Maybe SymBool" - [ testCase "Nothing" $ - extractSymbolics (Nothing :: Maybe SymBool) @?= emptySet, - testCase "Just v" $ - extractSymbolics (Just (ssymBool "a")) - @?= buildSymbolSet (ssymbolBool "a") - ], - testGroup - "Either SymBool SymBool" - [ testCase "Left v" $ - extractSymbolics - (Left (ssymBool "a") :: Either SymBool SymBool) - @?= buildSymbolSet (ssymbolBool "a"), - testCase "Right v" $ - extractSymbolics - (Right (ssymBool "a") :: Either SymBool SymBool) - @?= buildSymbolSet (ssymbolBool "a") - ], - testGroup - "MaybeT Maybe SymBool" - [ testCase "MaybeT Nothing" $ - extractSymbolics (MaybeT Nothing :: MaybeT Maybe SymBool) - @?= emptySet, - testCase "MaybeT (Just Nothing)" $ - extractSymbolics (MaybeT (Just Nothing) :: MaybeT Maybe SymBool) - @?= emptySet, - testCase "MaybeT (Just (Just v))" $ - extractSymbolics (MaybeT (Just (Just (ssymBool "a")))) - @?= buildSymbolSet (ssymbolBool "a") - ], - testGroup - "ExceptT SymBool Maybe SymBool" - [ testCase "ExceptT Nothing" $ - extractSymbolics - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @?= emptySet, - testCase "ExceptT (Just (Left v))" $ - extractSymbolics - ( ExceptT (Just (Left (ssymBool "a"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= buildSymbolSet (ssymbolBool "a"), - testCase "ExceptT (Just (Right v))" $ - extractSymbolics - ( ExceptT (Just (Right (ssymBool "a"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= buildSymbolSet (ssymbolBool "a") - ], - testGroup - "WriterT SymBool Maybe SymBool" - [ testGroup - "Lazy" - [ testCase "WriterT Nothing" $ - extractSymbolics - ( WriterLazy.WriterT Nothing :: - WriterLazy.WriterT SymBool Maybe SymBool - ) - @?= emptySet, - testCase "WriterT (Just (v1, v2))" $ - extractSymbolics - ( WriterLazy.WriterT - (Just (ssymBool "a", ssymBool "b")) :: - WriterLazy.WriterT SymBool Maybe SymBool - ) - @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b") - ], - testGroup - "Strict" - [ testCase "WriterT Nothing" $ - extractSymbolics - ( WriterStrict.WriterT Nothing :: - WriterStrict.WriterT SymBool Maybe SymBool - ) - @?= emptySet, - testCase "WriterT (Just (v1, v2))" $ - extractSymbolics - ( WriterStrict.WriterT - (Just (ssymBool "a", ssymBool "b")) :: - WriterStrict.WriterT SymBool Maybe SymBool - ) - @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b") - ] - ], - testProperty "()" (ioProperty . concreteExtractSymbolicsOkProp @()), - testCase "(,)" $ - extractSymbolics (ssymBool "a", ssymBool "b") - @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b"), - testCase "(,,)" $ - extractSymbolics (ssymBool "a", ssymBool "b", ssymBool "c") - @?= buildSymbolSet - (ssymbolBool "a", ssymbolBool "b", ssymbolBool "c"), - testGroup - "ByteString" - [ testCase "\"\"" $ - extractSymbolics ("" :: B.ByteString) @?= emptySet, - testCase "\"a\"" $ - extractSymbolics ("a" :: B.ByteString) @?= emptySet - ], - testCase "Identity SymBool" $ - extractSymbolics (Identity (ssymBool "a")) - @?= buildSymbolSet (ssymbolBool "a"), - testGroup - "IdentityT (Either SymBool) SymBool" - [ testCase "Identity (Left v)" $ - extractSymbolics - ( IdentityT $ Left (ssymBool "a") :: - IdentityT (Either SymBool) SymBool - ) - @?= buildSymbolSet (ssymbolBool "a"), - testCase "Identity (Right v)" $ - extractSymbolics - ( IdentityT $ Right (ssymBool "a") :: - IdentityT (Either SymBool) SymBool - ) - @?= buildSymbolSet (ssymbolBool "a") - ] - ], - testGroup - "deriving ExtractSymbolics for ADT" - [ testGroup - "Simple ADT" - [ testCase "A1" $ - extractSymbolics A1 @?= emptySet, - testCase "A2" $ - extractSymbolics (A2 (ssymBool "a")) - @?= buildSymbolSet (ssymbolBool "a"), - testCase "A3" $ - extractSymbolics (A3 (ssymBool "a") (ssymBool "b")) - @?= buildSymbolSet (ssymbolBool "a", ssymbolBool "b") - ] - ] - ] diff --git a/test/Grisette/Core/Data/Class/GPrettyTests.hs b/test/Grisette/Core/Data/Class/GPrettyTests.hs deleted file mode 100644 --- a/test/Grisette/Core/Data/Class/GPrettyTests.hs +++ /dev/null @@ -1,394 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Grisette.Core.Data.Class.GPrettyTests (gprettyTests) where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity (Identity, IdentityT (IdentityT)) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy -import qualified Data.HashMap.Lazy as HM -import qualified Data.HashSet as HS -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Text as T (Text, pack, unpack) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Generics (Generic) -import GHC.Stack (HasCallStack) -import Generics.Deriving (Default (Default)) -import Grisette - ( GPretty (gpretty), - IntN, - LogicalOp ((.&&)), - SymBool, - WordN, - pattern SomeIntN, - pattern SomeWordN, - ) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit ((@=?)) -import Test.QuickCheck (Arbitrary (arbitrary), Gen, forAll, oneof) - -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter - ( PageWidth(AvailablePerLine, Unbounded), - layoutPretty, - LayoutOptions(LayoutOptions), - ) -import Prettyprinter.Render.Text (renderStrict) -#else -import Data.Text.Prettyprint.Doc - ( PageWidth(AvailablePerLine, Unbounded), - layoutPretty, - LayoutOptions(LayoutOptions), - ) -import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) -#endif - -testGPretty :: (HasCallStack, GPretty a) => String -> Int -> a -> T.Text -> Test -testGPretty n i a s = - testCase n $ - renderStrict - ( layoutPretty - (LayoutOptions $ AvailablePerLine i 1) - (gpretty a) - ) - @=? s - -propertyGPrettyShow :: - forall a. - (HasCallStack, GPretty a, Show a) => - String -> - Gen a -> - Test -propertyGPrettyShow n g = - testProperty n $ forAll g $ \(a :: a) -> do - renderStrict (layoutPretty (LayoutOptions Unbounded) (gpretty a)) - == T.pack (show a) - -propertyGPrettyRead :: - forall a. - (HasCallStack, GPretty a, Read a, Show a, Eq a) => - String -> - Gen a -> - Test -propertyGPrettyRead n g = - testProperty n $ \i -> forAll g $ \(a :: a) -> do - read - ( T.unpack - ( renderStrict - ( layoutPretty - (LayoutOptions $ AvailablePerLine (abs i) 0.8) - (gpretty a) - ) - ) - ) - == a - -propertyGPretty :: - forall a. - (HasCallStack, GPretty a, Read a, Show a, Eq a) => - String -> - Gen a -> - Test -propertyGPretty n g = - testGroup - n - [ propertyGPrettyShow "single line" g, - propertyGPrettyRead "compact" g - ] - -data I5 a b = a :-: b - deriving (Generic, Show, Read, Eq) - deriving (GPretty) via (Default (I5 a b)) - -infixl 5 :-: - -data I6 a b = a :--: b - deriving (Generic, Show, Read, Eq) - deriving (GPretty) via (Default (I6 a b)) - -infixl 6 :--: - -instance - (Arbitrary a, Arbitrary b) => - Arbitrary (I5 a b) - where - arbitrary = do - a <- arbitrary - b <- arbitrary - return $ a :-: b - -instance - (Arbitrary a, Arbitrary b) => - Arbitrary (I6 a b) - where - arbitrary = do - a <- arbitrary - b <- arbitrary - return $ a :--: b - -data Record a b = Record {ra :: a, rb :: b} - deriving (Generic, Show, Read, Eq) - deriving (GPretty) via (Default (Record a b)) - -instance - (Arbitrary a, Arbitrary b) => - Arbitrary (Record a b) - where - arbitrary = do - a <- arbitrary - Record a <$> arbitrary - -gprettyTests :: Test -gprettyTests = - testGroup - "GPretty" - [ testGroup - "simple tests" - [ propertyGPretty "Bool" (arbitrary :: Gen Bool), - propertyGPretty "Integer" (arbitrary :: Gen Integer), - propertyGPretty "Int" (arbitrary :: Gen Int), - propertyGPretty "Int8" (arbitrary :: Gen Int8), - propertyGPretty "Int16" (arbitrary :: Gen Int16), - propertyGPretty "Int32" (arbitrary :: Gen Int32), - propertyGPretty "Int64" (arbitrary :: Gen Int64), - propertyGPretty "Word" (arbitrary :: Gen Word), - propertyGPretty "Word8" (arbitrary :: Gen Word8), - propertyGPretty "Word16" (arbitrary :: Gen Word16), - propertyGPretty "Word32" (arbitrary :: Gen Word32), - propertyGPretty "Word64" (arbitrary :: Gen Word64), - propertyGPrettyShow - "SomeWordN" - ( oneof - [ SomeWordN <$> (arbitrary :: Gen (WordN 8)), - SomeWordN <$> (arbitrary :: Gen (WordN 9)), - SomeWordN <$> (arbitrary :: Gen (WordN 10)) - ] - ), - propertyGPretty "WordN 8" (arbitrary :: Gen (WordN 8)), - propertyGPretty "WordN 9" (arbitrary :: Gen (WordN 9)), - propertyGPrettyShow - "SomeIntN" - ( oneof - [ SomeIntN <$> (arbitrary :: Gen (IntN 8)), - SomeIntN <$> (arbitrary :: Gen (IntN 9)), - SomeIntN <$> (arbitrary :: Gen (IntN 10)) - ] - ), - propertyGPretty "IntN 8" (arbitrary :: Gen (IntN 8)), - propertyGPretty "IntN 9" (arbitrary :: Gen (IntN 9)), - propertyGPretty "()" (arbitrary :: Gen ()), - propertyGPretty - "Either" - ( arbitrary :: Gen (Either Int Bool) - ), - propertyGPretty - "Maybe" - ( arbitrary :: Gen (Maybe Int) - ), - propertyGPretty - "List" - ( arbitrary :: Gen [Int] - ), - propertyGPretty - "(,)" - ( arbitrary :: Gen (Int, Int) - ), - propertyGPretty - "(,,)" - ( arbitrary :: Gen (Int, Int, Int) - ), - propertyGPretty - "(,,,)" - ( arbitrary :: Gen (Int, Int, Int, Int) - ), - propertyGPretty - "(,,,,)" - ( arbitrary :: Gen (Int, Int, Int, Int, Int) - ), - propertyGPretty - "(,,,,,)" - ( arbitrary :: Gen (Int, Int, Int, Int, Int, Int) - ), - propertyGPretty - "(,,,,,,)" - ( arbitrary :: Gen (Int, Int, Int, Int, Int, Int, Int) - ), - propertyGPretty - "(,,,,,,,)" - ( arbitrary :: Gen (Int, Int, Int, Int, Int, Int, Int, Int) - ), - propertyGPretty - "I5" - ( arbitrary :: Gen (I5 Int Int) - ), - propertyGPretty - "Record" - ( arbitrary :: Gen (Record Int Int) - ) - ], - testGroup - "Combined types" - [ propertyGPretty - "Maybe Maybe" - ( arbitrary :: Gen (Maybe (Maybe Int)) - ), - propertyGPretty - "Maybe (,)" - ( arbitrary :: Gen (Maybe (Int, Int)) - ), - propertyGPretty - "Maybe I5" - ( arbitrary :: Gen (Maybe (I5 Int Int)) - ), - propertyGPretty - "Maybe []" - ( arbitrary :: Gen (Maybe [Int]) - ), - propertyGPretty - "Maybe Record" - ( arbitrary :: Gen (Maybe (Record Int Int)) - ), - propertyGPretty - "(Maybe,Either)" - ( arbitrary :: Gen (Maybe Int, Either Int Int) - ), - propertyGPretty - "((,),(,))" - ( arbitrary :: Gen ((Int, Int), (Int, Int)) - ), - propertyGPretty - "(I5,I5)" - ( arbitrary :: Gen (I5 Int Int, I5 Int Int) - ), - propertyGPretty - "([],[])" - ( arbitrary :: Gen ([Int], [Int]) - ), - propertyGPretty - "(Record,Record)" - ( arbitrary :: Gen (Record Int Int, Record Int Int) - ), - propertyGPretty - "I5 Maybe Either" - ( arbitrary :: Gen (I5 (Maybe Int) (Either Int Int)) - ), - propertyGPretty - "I5 (,) (,)" - ( arbitrary :: Gen (I5 (Int, Int) (Int, Int)) - ), - propertyGPretty - "I5 I6 I6" - ( arbitrary :: Gen (I5 (I6 Int Int) (I6 Int Int)) - ), - propertyGPretty - "I5 I5 I5" - ( arbitrary :: Gen (I5 (I5 Int Int) (I5 Int Int)) - ), - propertyGPretty - "I6 I5 I5" - ( arbitrary :: Gen (I6 (I5 Int Int) (I5 Int Int)) - ), - propertyGPretty - "I6 I6 I6" - ( arbitrary :: Gen (I6 (I6 Int Int) (I6 Int Int)) - ), - propertyGPretty - "I5 [] []" - ( arbitrary :: Gen (I5 [Int] [Int]) - ), - propertyGPretty - "I5 Record Record" - ( arbitrary :: Gen (I5 (Record Int Int) (Record Int Int)) - ), - propertyGPretty - "[Maybe]" - ( arbitrary :: Gen [Maybe Int] - ), - propertyGPretty - "[(,)]" - ( arbitrary :: Gen [(Int, Int)] - ), - propertyGPretty - "[I5]" - ( arbitrary :: Gen [I5 Int Int] - ), - propertyGPretty - "[[]]" - ( arbitrary :: Gen [[Int]] - ), - propertyGPretty - "[Record]" - ( arbitrary :: Gen [Record Int Int] - ), - propertyGPretty - "Record Maybe Either" - ( arbitrary :: Gen (Record (Maybe Int) (Either Int Int)) - ), - propertyGPretty - "Record (,) (,)" - ( arbitrary :: Gen (Record (Int, Int) (Int, Int)) - ), - propertyGPretty - "Record I5 I6" - ( arbitrary :: Gen (Record (I5 Int Int) (I6 Int Int)) - ), - propertyGPretty - "Record []" - ( arbitrary :: Gen (Record [Int] [Int]) - ), - propertyGPretty - "Record Record" - ( arbitrary :: Gen (Record (Record Int Int) (Record Int Int)) - ), - propertyGPretty - "Maybe (MaybeT Identity Int)" - (Just . MaybeT <$> arbitrary :: Gen (Maybe (MaybeT Identity Int))), - propertyGPretty - "Maybe (ExceptT Int Identity Int)" - ( Just . ExceptT <$> arbitrary :: - Gen (Maybe (ExceptT Int Identity Int)) - ), - propertyGPretty - "Maybe (LazyWriterT Int Identity Int)" - ( Just . WriterLazy.WriterT <$> arbitrary :: - Gen (Maybe (WriterLazy.WriterT Int Identity Int)) - ), - propertyGPretty - "Maybe (StrictWriterT Int Identity Int)" - ( Just . WriterLazy.WriterT <$> arbitrary :: - Gen (Maybe (WriterLazy.WriterT Int Identity Int)) - ), - propertyGPretty - "Maybe (IdentityT Identity Int)" - ( Just . IdentityT <$> arbitrary :: - Gen (Maybe (IdentityT Identity Int)) - ), - propertyGPrettyShow - "HS.HashSet Int" - (HS.fromList <$> arbitrary :: Gen (HS.HashSet Int)), - propertyGPrettyShow - "HM.HashMap Int Int" - (HM.fromList <$> arbitrary :: Gen (HM.HashMap Int Int)) - ], - testGroup - "Symbolic types" - [ testGPretty - "enough space" - 80 - ("a" .&& "b" :: SymBool) - "(&& a b)", - testGPretty - "not enough space" - 6 - ("a" .&& "b" :: SymBool) - "..." - ] - ] diff --git a/test/Grisette/Core/Data/Class/GenSymTests.hs b/test/Grisette/Core/Data/Class/GenSymTests.hs --- a/test/Grisette/Core/Data/Class/GenSymTests.hs +++ b/test/Grisette/Core/Data/Class/GenSymTests.hs @@ -35,7 +35,7 @@ withInfo, ) import Grisette.Core.Data.Class.TestValues (conBool, isymBool, ssymBool) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM) +import Grisette.Internal.Core.Control.Monad.Union (Union) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) @@ -51,7 +51,7 @@ [ testGroup "() spec" [ testCase "genSym" $ - (genSym () "a" :: UnionM SymBool) + (genSym () "a" :: Union SymBool) @?= mrgSingle (isymBool "a" 0), testCase "genSymSimple" $ (genSymSimple () "a" :: SymBool) @@ -60,7 +60,7 @@ testGroup "SymBool spec" [ testCase "genSym" $ - (genSym (conBool True) "a" :: UnionM SymBool) + (genSym (conBool True) "a" :: Union SymBool) @?= mrgSingle (isymBool "a" 0), testCase "genSymSimple" $ (genSymSimple (conBool True) "a" :: SymBool) @@ -70,17 +70,17 @@ testGroup "Bool" [ testCase "() spec" $ - (genSym () "a" :: UnionM Bool) + (genSym () "a" :: Union Bool) @?= mrgIf (isymBool "a" 0) (mrgSingle False) (mrgSingle True), testGroup "Bool spec" [ testGroup "genSym" [ testCase "True" $ - (genSym True "a" :: UnionM Bool) + (genSym True "a" :: Union Bool) @?= mrgSingle True, testCase "False" $ - (genSym False "a" :: UnionM Bool) + (genSym False "a" :: Union Bool) @?= mrgSingle False ], testGroup @@ -99,7 +99,7 @@ [ testGroup "Integer spec" [ testCase "genSym" $ - (genSym (1 :: Integer) "a" :: UnionM Integer) + (genSym (1 :: Integer) "a" :: Union Integer) @?= mrgSingle 1, testCase "genSymSimple" $ (genSymSimple (1 :: Integer) "a" :: Integer) @@ -107,14 +107,14 @@ ], testCase "Upper bound spec" $ ( genSym (EnumGenUpperBound (3 :: Integer)) "a" :: - UnionM Integer + Union Integer ) @?= mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgIf (isymBool "a" 1) (mrgSingle 1) (mrgSingle 2)), testCase "Bound spec" $ - (genSym (EnumGenBound (-1 :: Integer) 2) "a" :: UnionM Integer) + (genSym (EnumGenBound (-1 :: Integer) 2) "a" :: Union Integer) @?= mrgIf (isymBool "a" 0) (mrgSingle (-1)) @@ -125,13 +125,13 @@ [ testGroup "Char spec" [ testCase "genSym" $ - (genSym 'x' "a" :: UnionM Char) + (genSym 'x' "a" :: Union Char) @?= mrgSingle 'x', testCase "genSymSimple" $ (genSymSimple 'x' "a" :: Char) @?= 'x' ], testCase "Upper bound spec" $ - (genSym (EnumGenUpperBound @Char (toEnum 3)) "a" :: UnionM Char) + (genSym (EnumGenUpperBound @Char (toEnum 3)) "a" :: Union Char) @?= mrgIf (isymBool "a" 0) (mrgSingle $ toEnum 0) @@ -141,7 +141,7 @@ (mrgSingle $ toEnum 2) ), testCase "Bound spec" $ - (genSym (EnumGenBound 'a' 'd') "a" :: UnionM Char) + (genSym (EnumGenBound 'a' 'd') "a" :: Union Char) @?= mrgIf (isymBool "a" 0) (mrgSingle 'a') @@ -155,7 +155,7 @@ "Nothing" [ testCase "genSym" $ ( genSym (Nothing :: Maybe SymBool) "a" :: - UnionM (Maybe SymBool) + Union (Maybe SymBool) ) @?= mrgSingle Nothing, testCase "genSymSimple" $ @@ -168,7 +168,7 @@ "Just v" [ testCase "genSym" $ ( genSym (Just (ssymBool "a")) "a" :: - UnionM (Maybe SymBool) + Union (Maybe SymBool) ) @?= mrgSingle (Just (isymBool "a" 0)), testCase "genSymSimple" $ @@ -179,7 +179,7 @@ ] ], testCase "() spec" $ - (genSym () "a" :: UnionM (Maybe SymBool)) + (genSym () "a" :: Union (Maybe SymBool)) @?= mrgIf (isymBool "a" 0) (mrgSingle Nothing) @@ -197,7 +197,7 @@ Either SymBool SymBool ) "a" :: - UnionM (Either SymBool SymBool) + Union (Either SymBool SymBool) ) @?= mrgSingle (Left (isymBool "a" 0)), testCase "genSymSimple" $ @@ -218,7 +218,7 @@ Either SymBool SymBool ) "a" :: - UnionM (Either SymBool SymBool) + Union (Either SymBool SymBool) ) @?= mrgSingle (Right (isymBool "a" 0)), testCase "genSymSimple" $ @@ -233,7 +233,7 @@ ] ], testCase "() spec" $ do - (genSym () "a" :: UnionM (Either SymBool SymBool)) + (genSym () "a" :: Union (Either SymBool SymBool)) @?= mrgIf (isymBool "a" 0) (mrgSingle $ Left $ isymBool "a" 1) @@ -244,10 +244,10 @@ [ testGroup "Max length spec" [ testCase "max length = 0" $ - (genSym (0 :: Integer) "a" :: UnionM [SymBool]) + (genSym (0 :: Integer) "a" :: Union [SymBool]) @?= mrgSingle [], testCase "max length = 3" $ - (genSym (3 :: Integer) "a" :: UnionM [SymBool]) + (genSym (3 :: Integer) "a" :: Union [SymBool]) @?= mrgIf (isymBool "a" 3) (mrgSingle []) @@ -269,7 +269,7 @@ testGroup "Min & max length spec" [ testCase "min length = 1, max length = 3" $ - (genSym (ListSpec 1 3 ()) "a" :: UnionM [SymBool]) + (genSym (ListSpec 1 3 ()) "a" :: Union [SymBool]) @?= mrgIf (isymBool "a" 3) (mrgSingle [isymBool "a" 2]) @@ -285,7 +285,7 @@ ), testCase "min length = 1, max length = 2, nested" $ ( genSym (ListSpec 1 2 (ListSpec 1 2 ())) "a" :: - UnionM [UnionM [SymBool]] + Union [Union [SymBool]] ) @?= mrgIf (isymBool "a" 6) @@ -313,7 +313,7 @@ [ testGroup "length = 2" [ testCase "genSym" $ - (genSym (SimpleListSpec 2 ()) "a" :: UnionM [SymBool]) + (genSym (SimpleListSpec 2 ()) "a" :: Union [SymBool]) @?= mrgSingle [isymBool "a" 0, isymBool "a" 1], testCase "genSymSimple" $ (genSymSimple (SimpleListSpec 2 ()) "a" :: [SymBool]) @@ -325,7 +325,7 @@ ( genSym (SimpleListSpec 2 (SimpleListSpec 2 ())) "a" :: - UnionM [[SymBool]] + Union [[SymBool]] ) @?= mrgSingle [ [isymBool "a" 0, isymBool "a" 1], @@ -348,7 +348,7 @@ ( genSym [[conBool True], [ssymBool "a", ssymBool "b"]] "a" :: - UnionM [[SymBool]] + Union [[SymBool]] ) @?= mrgSingle [ [isymBool "a" 0], @@ -368,7 +368,7 @@ testGroup "()" [ testCase "() spec" $ do - (genSym () "a" :: UnionM ()) @?= mrgSingle () + (genSym () "a" :: Union ()) @?= mrgSingle () (genSymSimple () "a" :: ()) @?= () ], testGroup @@ -381,7 +381,7 @@ EnumGenUpperBound @Integer 2 ) "a" :: - UnionM (Integer, Integer) + Union (Integer, Integer) ) @?= do x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1) @@ -406,7 +406,7 @@ testGroup "No spec" [ testCase "genSym" $ - (genSym () "a" :: UnionM (SymBool, SymBool)) + (genSym () "a" :: Union (SymBool, SymBool)) @?= mrgSingle (isymBool "a" 0, isymBool "a" 1), testCase "genSymSimple" $ (genSymSimple () "a" :: (SymBool, SymBool)) @@ -424,7 +424,7 @@ EnumGenUpperBound @Integer 2 ) "a" :: - UnionM (Integer, Integer, Integer) + Union (Integer, Integer, Integer) ) @?= do x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1) @@ -447,7 +447,7 @@ testGroup "No spec" [ testCase "genSym" $ - (genSym () "a" :: UnionM (SymBool, SymBool, SymBool)) + (genSym () "a" :: Union (SymBool, SymBool, SymBool)) @?= mrgSingle (isymBool "a" 0, isymBool "a" 1, isymBool "a" 2), testCase "genSymSimple" $ @@ -467,7 +467,7 @@ EnumGenUpperBound @Integer 2 ) "a" :: - UnionM (Integer, Integer, Integer, Integer) + Union (Integer, Integer, Integer, Integer) ) @?= do x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1) @@ -497,7 +497,7 @@ "No spec" [ testCase "genSym" $ ( genSym () "a" :: - UnionM (SymBool, SymBool, SymBool, SymBool) + Union (SymBool, SymBool, SymBool, SymBool) ) @?= mrgSingle ( isymBool "a" 0, @@ -529,7 +529,7 @@ EnumGenUpperBound @Integer 2 ) "a" :: - UnionM (Integer, Integer, Integer, Integer, Integer) + Union (Integer, Integer, Integer, Integer, Integer) ) @?= do x1 <- mrgIf (isymBool "a" 0) (mrgSingle 0) (mrgSingle 1) @@ -564,7 +564,7 @@ "No spec" [ testCase "genSym" $ ( genSym () "a" :: - UnionM (SymBool, SymBool, SymBool, SymBool, SymBool) + Union (SymBool, SymBool, SymBool, SymBool, SymBool) ) @?= mrgSingle ( isymBool "a" 0, @@ -599,7 +599,7 @@ EnumGenUpperBound @Integer 2 ) "a" :: - UnionM + Union ( Integer, Integer, Integer, @@ -650,7 +650,7 @@ "No spec" [ testCase "genSym" $ ( genSym () "a" :: - UnionM + Union ( SymBool, SymBool, SymBool, @@ -701,7 +701,7 @@ EnumGenUpperBound @Integer 2 ) "a" :: - UnionM + Union ( Integer, Integer, Integer, @@ -757,7 +757,7 @@ "No spec" [ testCase "genSym" $ ( genSym () "a" :: - UnionM + Union ( SymBool, SymBool, SymBool, @@ -813,7 +813,7 @@ EnumGenUpperBound @Integer 2 ) "a" :: - UnionM + Union ( Integer, Integer, Integer, @@ -874,7 +874,7 @@ "No spec" [ testCase "genSym" $ ( genSym () "a" :: - UnionM + Union ( SymBool, SymBool, SymBool, @@ -926,7 +926,7 @@ "MaybeT Nothing" [ testCase "genSym" $ ( genSym (MaybeT Nothing :: MaybeT Maybe SymBool) "a" :: - UnionM (MaybeT Maybe SymBool) + Union (MaybeT Maybe SymBool) ) @?= mrgSingle (MaybeT Nothing), testCase "genSymSimple" $ @@ -945,7 +945,7 @@ MaybeT Maybe SymBool ) "a" :: - UnionM (MaybeT Maybe SymBool) + Union (MaybeT Maybe SymBool) ) @?= mrgSingle (MaybeT (Just Nothing)), testCase "genSymSimple" $ @@ -966,7 +966,7 @@ MaybeT Maybe SymBool ) "a" :: - UnionM (MaybeT Maybe SymBool) + Union (MaybeT Maybe SymBool) ) @?= mrgSingle (MaybeT (Just (Just $ isymBool "a" 0))), testCase "genSymSimple" $ @@ -981,7 +981,7 @@ ] ], testCase "No spec" $ - (genSym () "a" :: UnionM (MaybeT Maybe SymBool)) + (genSym () "a" :: Union (MaybeT Maybe SymBool)) @?= mrgIf (isymBool "a" 0) (mrgSingle $ MaybeT Nothing) @@ -996,7 +996,7 @@ "Nothing" [ testCase "genSym" $ ( genSym (Nothing :: Maybe (Maybe SymBool)) "a" :: - UnionM (MaybeT Maybe SymBool) + Union (MaybeT Maybe SymBool) ) @?= mrgSingle (MaybeT Nothing), testCase "genSymSimple" $ @@ -1009,7 +1009,7 @@ "Just Nothing" [ testCase "genSym" $ ( genSym (Just Nothing :: Maybe (Maybe SymBool)) "a" :: - UnionM (MaybeT Maybe SymBool) + Union (MaybeT Maybe SymBool) ) @?= mrgSingle (MaybeT (Just Nothing)), testCase "genSymSimple" $ @@ -1028,7 +1028,7 @@ Maybe (Maybe SymBool) ) "a" :: - UnionM (MaybeT Maybe SymBool) + Union (MaybeT Maybe SymBool) ) @?= mrgSingle (MaybeT (Just (Just $ isymBool "a" 0))), testCase "genSymSimple" $ @@ -1055,7 +1055,7 @@ ExceptT SymBool Maybe SymBool ) "a" :: - UnionM (ExceptT SymBool Maybe SymBool) + Union (ExceptT SymBool Maybe SymBool) ) @?= mrgSingle (ExceptT Nothing), testCase "genSymSimple" $ @@ -1076,7 +1076,7 @@ ExceptT SymBool Maybe SymBool ) "a" :: - UnionM (ExceptT SymBool Maybe SymBool) + Union (ExceptT SymBool Maybe SymBool) ) @?= mrgSingle (ExceptT $ Just $ Left $ isymBool "a" 0), @@ -1098,7 +1098,7 @@ ExceptT SymBool Maybe SymBool ) "a" :: - UnionM (ExceptT SymBool Maybe SymBool) + Union (ExceptT SymBool Maybe SymBool) ) @?= mrgSingle (ExceptT $ Just $ Right $ isymBool "a" 0), @@ -1114,7 +1114,7 @@ ] ], testCase "() spec" $ do - (genSym () "a" :: UnionM (ExceptT SymBool Maybe SymBool)) + (genSym () "a" :: Union (ExceptT SymBool Maybe SymBool)) @?= mrgIf (isymBool "a" 0) (mrgSingle $ ExceptT Nothing) @@ -1131,7 +1131,7 @@ ( genSym (Nothing :: Maybe (Either SymBool SymBool)) "a" :: - UnionM (ExceptT SymBool Maybe SymBool) + Union (ExceptT SymBool Maybe SymBool) ) @?= mrgSingle (ExceptT Nothing), testCase "genSymSimple" $ @@ -1150,7 +1150,7 @@ Maybe (Either SymBool SymBool) ) "a" :: - UnionM (ExceptT SymBool Maybe SymBool) + Union (ExceptT SymBool Maybe SymBool) ) @?= mrgSingle (ExceptT (Just (Left $ isymBool "a" 0))), @@ -1172,7 +1172,7 @@ Maybe (Either SymBool SymBool) ) "a" :: - UnionM (ExceptT SymBool Maybe SymBool) + Union (ExceptT SymBool Maybe SymBool) ) @?= mrgSingle (ExceptT (Just (Right $ isymBool "a" 0))), @@ -1192,13 +1192,13 @@ testGroup "choose*" [ testCase "chooseFresh" $ do - (runFresh (chooseFresh [1, 2, 3]) "a" :: UnionM Int) + (runFresh (chooseFresh [1, 2, 3]) "a" :: Union Int) @?= mrgIf (isymBool "a" 0) (mrgSingle 1) (mrgIf (isymBool "a" 1) (mrgSingle 2) (mrgSingle 3)), testCase "choose" $ do - (choose [1, 2, 3] "a" :: UnionM Int) + (choose [1, 2, 3] "a" :: Union Int) @?= mrgIf (isymBool "a" 0) (mrgSingle 1) @@ -1224,7 +1224,7 @@ ] ) "a" :: - UnionM Int + Union Int ) @?= mrgIf (isymBool "a" 0) @@ -1241,7 +1241,7 @@ mrgIf (ssymBool "x") 3 4 ] "a" :: - UnionM Int + Union Int ) @?= mrgIf (isymBool "a" 0) @@ -1257,7 +1257,7 @@ r1 <- liftFresh orig r2 <- liftFresh orig return (r1, r2) :: - FreshT UnionM ((SymBool, SymBool), (SymBool, SymBool)) + FreshT Union ((SymBool, SymBool), (SymBool, SymBool)) let expected = return ( (isymBool "a" 0, isymBool "a" 1), diff --git a/test/Grisette/Core/Data/Class/MergeableTests.hs b/test/Grisette/Core/Data/Class/MergeableTests.hs --- a/test/Grisette/Core/Data/Class/MergeableTests.hs +++ b/test/Grisette/Core/Data/Class/MergeableTests.hs @@ -36,7 +36,7 @@ Solvable (con, ssym), StrategyList (StrategyList), SymBool, - UnionM, + Union, buildStrategyList, mrgIf, mrgSingle, @@ -679,11 +679,11 @@ let SimpleStrategy s = rootStrategy :: MergingStrategy - (StateLazy.StateT Integer UnionM SymBool) - let st1 :: StateLazy.StateT Integer UnionM SymBool = + (StateLazy.StateT Integer Union SymBool) + let st1 :: StateLazy.StateT Integer Union SymBool = StateLazy.StateT $ \(x :: Integer) -> mrgSingle (ssym "a", x + 2) - let st2 :: StateLazy.StateT Integer UnionM SymBool = + let st2 :: StateLazy.StateT Integer Union SymBool = StateLazy.StateT $ \(x :: Integer) -> mrgSingle (ssym "b", x * 2) let st3 = s (ssym "c") st1 st2 @@ -698,11 +698,11 @@ let SimpleStrategy s = rootStrategy :: MergingStrategy - (StateStrict.StateT Integer UnionM SymBool) - let st1 :: StateStrict.StateT Integer UnionM SymBool = + (StateStrict.StateT Integer Union SymBool) + let st1 :: StateStrict.StateT Integer Union SymBool = StateStrict.StateT $ \(x :: Integer) -> mrgSingle (ssym "a", x + 2) - let st2 :: StateStrict.StateT Integer UnionM SymBool = + let st2 :: StateStrict.StateT Integer Union SymBool = StateStrict.StateT $ \(x :: Integer) -> mrgSingle (ssym "b", x * 2) let st3 = s (ssym "c") st1 st2 @@ -718,10 +718,10 @@ let SimpleStrategy s = rootStrategy :: MergingStrategy - (ContT (SymBool, Integer) UnionM (SymBool, Integer)) - let c1 :: ContT (SymBool, Integer) UnionM (SymBool, Integer) = + (ContT (SymBool, Integer) Union (SymBool, Integer)) + let c1 :: ContT (SymBool, Integer) Union (SymBool, Integer) = ContT $ \f -> f (ssym "a", 2) - let c2 :: ContT (SymBool, Integer) UnionM (SymBool, Integer) = + let c2 :: ContT (SymBool, Integer) Union (SymBool, Integer) = ContT $ \f -> f (ssym "b", 3) let c3 = s (ssym "c") c1 c2 runContT @@ -754,7 +754,7 @@ (Integer, SymBool) (Integer, SymBool) (Integer, SymBool) - UnionM + Union (Integer, SymBool) ) let rws1 :: @@ -762,7 +762,7 @@ (Integer, SymBool) (Integer, SymBool) (Integer, SymBool) - UnionM + Union (Integer, SymBool) = RWSTLazy.RWST $ \(ir, br) (is, bs) -> mrgSingle @@ -775,7 +775,7 @@ (Integer, SymBool) (Integer, SymBool) (Integer, SymBool) - UnionM + Union (Integer, SymBool) = RWSTLazy.RWST $ \(ir, br) (is, bs) -> mrgSingle @@ -786,7 +786,7 @@ let rws3 = s (ssym "c") rws1 rws2 let res1 :: - UnionM + Union ( (Integer, SymBool), (Integer, SymBool), (Integer, SymBool) @@ -814,7 +814,7 @@ (Integer, SymBool) (Integer, SymBool) (Integer, SymBool) - UnionM + Union (Integer, SymBool) ) let rws1 :: @@ -822,7 +822,7 @@ (Integer, SymBool) (Integer, SymBool) (Integer, SymBool) - UnionM + Union (Integer, SymBool) = RWSTStrict.RWST $ \(ir, br) (is, bs) -> mrgSingle @@ -835,7 +835,7 @@ (Integer, SymBool) (Integer, SymBool) (Integer, SymBool) - UnionM + Union (Integer, SymBool) = RWSTStrict.RWST $ \(ir, br) (is, bs) -> mrgSingle @@ -846,7 +846,7 @@ let rws3 = s (ssym "c") rws1 rws2 let res1 :: - UnionM + Union ( (Integer, SymBool), (Integer, SymBool), (Integer, SymBool) @@ -873,12 +873,12 @@ let SimpleStrategy s = rootStrategy :: MergingStrategy - (WriterLazy.WriterT Integer UnionM SymBool) - let w1 :: WriterLazy.WriterT Integer UnionM SymBool = + (WriterLazy.WriterT Integer Union SymBool) + let w1 :: WriterLazy.WriterT Integer Union SymBool = WriterLazy.WriterT $ mrgSingle (ssym "a", 1) - let w2 :: WriterLazy.WriterT Integer UnionM SymBool = + let w2 :: WriterLazy.WriterT Integer Union SymBool = WriterLazy.WriterT $ mrgSingle (ssym "b", 2) - let w3 :: WriterLazy.WriterT Integer UnionM SymBool = + let w3 :: WriterLazy.WriterT Integer Union SymBool = WriterLazy.WriterT $ mrgSingle (ssym "c", 1) let w4 = s (ssym "d") w1 w2 let w5 = s (ssym "d") w1 w3 @@ -893,12 +893,12 @@ let SimpleStrategy s = rootStrategy :: MergingStrategy - (WriterStrict.WriterT Integer UnionM SymBool) - let w1 :: WriterStrict.WriterT Integer UnionM SymBool = + (WriterStrict.WriterT Integer Union SymBool) + let w1 :: WriterStrict.WriterT Integer Union SymBool = WriterStrict.WriterT $ mrgSingle (ssym "a", 1) - let w2 :: WriterStrict.WriterT Integer UnionM SymBool = + let w2 :: WriterStrict.WriterT Integer Union SymBool = WriterStrict.WriterT $ mrgSingle (ssym "b", 2) - let w3 :: WriterStrict.WriterT Integer UnionM SymBool = + let w3 :: WriterStrict.WriterT Integer Union SymBool = WriterStrict.WriterT $ mrgSingle (ssym "c", 1) let w4 = s (ssym "d") w1 w2 let w5 = s (ssym "d") w1 w3 @@ -913,10 +913,10 @@ testCase "ReaderT" $ do let SimpleStrategy s = rootStrategy :: - MergingStrategy (ReaderT Integer UnionM Integer) - let r1 :: ReaderT Integer UnionM Integer = + MergingStrategy (ReaderT Integer Union Integer) + let r1 :: ReaderT Integer Union Integer = ReaderT $ \(x :: Integer) -> mrgSingle $ x + 2 - let r2 :: ReaderT Integer UnionM Integer = + let r2 :: ReaderT Integer Union Integer = ReaderT $ \(x :: Integer) -> mrgSingle $ x * 2 let r3 = s (ssym "c") r1 r2 runReaderT r3 2 @?= mrgSingle 4 @@ -1064,17 +1064,17 @@ [ testCase "LT" $ testMergeableSimpleEquivClass LT - [DynamicSortedIdx False] + [DynamicSortedIdx LT] [(ssym "a", LT, LT, LT)], testCase "EQ" $ testMergeableSimpleEquivClass EQ - [DynamicSortedIdx True, DynamicSortedIdx False] + [DynamicSortedIdx EQ] [(ssym "a", EQ, EQ, EQ)], testCase "GT" $ testMergeableSimpleEquivClass GT - [DynamicSortedIdx True, DynamicSortedIdx True] + [DynamicSortedIdx GT] [(ssym "a", GT, GT, GT)] ] ] diff --git a/test/Grisette/Core/Data/Class/PPrintTests.hs b/test/Grisette/Core/Data/Class/PPrintTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/PPrintTests.hs @@ -0,0 +1,741 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Grisette.Core.Data.Class.PPrintTests (pprintTests) where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity (Identity, IdentityT (IdentityT)) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Trans.Writer.Lazy as WriterLazy +import qualified Data.HashMap.Lazy as HM +import qualified Data.HashSet as HS +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Text as T (Text, intercalate, pack, unpack) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Generics (Generic, Generic1) +import GHC.Stack (HasCallStack) +import Generics.Deriving (Default (Default), Default1 (Default1)) +import Grisette + ( IntN, + LogicalOp ((.&&)), + PPrint (pformat), + SymBool, + WordN, + pattern SomeIntN, + pattern SomeWordN, + ) +import Grisette.Internal.Core.Data.Class.PPrint + ( PPrint1, + PPrint2, + docToTextWithWidth, + pformatPrec1, + pformatPrec2, + pformatTextWithWidth, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit ((@?=)) +import Test.QuickCheck (Arbitrary (arbitrary), Gen, forAll, oneof) + +#if MIN_VERSION_prettyprinter(1,7,0) +import Prettyprinter + ( PageWidth(AvailablePerLine, Unbounded), + layoutPretty, + LayoutOptions(LayoutOptions), + ) +import Prettyprinter.Render.Text (renderStrict) +#else +import Data.Text.Prettyprint.Doc + ( PageWidth(AvailablePerLine, Unbounded), + layoutPretty, + LayoutOptions(LayoutOptions), + ) +import Data.Text.Prettyprint.Doc.Render.Text (renderStrict) +#endif + +testPPrint :: (HasCallStack, PPrint a) => String -> Int -> a -> T.Text -> Test +testPPrint n i a s = testCase n $ pformatTextWithWidth i a @?= s + +testPPrint1 :: + (HasCallStack, PPrint1 f, PPrint a) => + String -> + Int -> + f a -> + T.Text -> + Test +testPPrint1 n i a s = testCase n $ do + pformatTextWithWidth i a @?= s + docToTextWithWidth i (pformatPrec1 0 a) @?= s + +testPPrint2 :: + (HasCallStack, PPrint2 f, PPrint a, PPrint b) => + String -> + Int -> + f a b -> + T.Text -> + Test +testPPrint2 n i a s = testCase n $ do + pformatTextWithWidth i a @?= s + docToTextWithWidth i (pformatPrec1 0 a) @?= s + docToTextWithWidth i (pformatPrec2 0 a) @?= s + +propertyPFormatShow :: + forall a. + (HasCallStack, PPrint a, Show a) => + String -> + Gen a -> + Test +propertyPFormatShow n g = + testProperty n $ forAll g $ \(a :: a) -> do + renderStrict (layoutPretty (LayoutOptions Unbounded) (pformat a)) + == T.pack (show a) + +propertyPFormatRead :: + forall a. + (HasCallStack, PPrint a, Read a, Show a, Eq a) => + String -> + Gen a -> + Test +propertyPFormatRead n g = + testProperty n $ \i -> forAll g $ \(a :: a) -> do + read + ( T.unpack + ( renderStrict + ( layoutPretty + (LayoutOptions $ AvailablePerLine (abs i) 0.8) + (pformat a) + ) + ) + ) + == a + +data I5 a = a :-: a + deriving (Generic, Show, Read, Eq) + deriving (PPrint) via (Default (I5 a)) + +infixl 5 :-: + +data I6 a = a :--: a + deriving (Generic, Show, Read, Eq) + deriving (PPrint) via (Default (I6 a)) + +infixl 6 :--: + +instance + (Arbitrary a) => + Arbitrary (I5 a) + where + arbitrary = do + a <- arbitrary + b <- arbitrary + return $ a :-: b + +instance + (Arbitrary a) => + Arbitrary (I6 a) + where + arbitrary = do + a <- arbitrary + b <- arbitrary + return $ a :--: b + +data Record a b = Record {ra :: a, rb :: b} + deriving (Generic, Show, Read, Eq) + deriving (PPrint) via (Default (Record a b)) + +instance + (Arbitrary a, Arbitrary b) => + Arbitrary (Record a b) + where + arbitrary = do + a <- arbitrary + Record a <$> arbitrary + +data U1Test = U1Test + deriving (Generic, Show, Read, Eq) + deriving (PPrint) via (Default U1Test) + +newtype K1TestInt = K1Test Int + deriving (Generic, Show, Read, Eq) + deriving (PPrint) via (Default K1TestInt) + +newtype K1TestA a = K1TestA a + deriving (Generic, Generic1, Show, Read, Eq, Functor) + deriving (PPrint) via (Default (K1TestA a)) + deriving (PPrint1) via (Default1 K1TestA) + +newtype RecordK1TestA a = RecordK1TestA {recordK1TestA :: a} + deriving (Generic, Show, Read, Eq) + deriving (PPrint) via (Default (RecordK1TestA a)) + +data SumTestAB a b = SumTestAB a b + deriving (Generic, Generic1, Show, Read, Eq) + deriving (PPrint) via (Default (SumTestAB a b)) + deriving (PPrint1) via (Default1 (SumTestAB a)) + +data RecordSumTest a = RecordSumTest + { recordSumTest1 :: a, + recordSumTest2 :: a + } + deriving (Generic, Show, Read, Eq) + deriving (PPrint) via (Default (RecordSumTest a)) + +newtype Rec1Test f b = Rec1Test (f b) + deriving (Generic, Generic1, Show, Eq) + +deriving via + (Default (Rec1Test f a)) + instance + (PPrint1 f, PPrint a) => PPrint (Rec1Test f a) + +deriving via + (Default1 (Rec1Test f)) + instance + (PPrint1 f) => PPrint1 (Rec1Test f) + +newtype Comp1Test f g b = Comp1Test (f (g b)) + deriving (Generic, Generic1, Show, Eq) + +deriving via + (Default (Comp1Test f g a)) + instance + (PPrint1 f, PPrint1 g, PPrint a) => PPrint (Comp1Test f g a) + +deriving via + (Default1 (Comp1Test f g)) + instance + (PPrint1 f, PPrint1 g, Functor f) => PPrint1 (Comp1Test f g) + +pprintTests :: Test +pprintTests = + testGroup + "PPrint" + [ testGroup + "Derivation" + [ testGroup + "List" + [ testPPrint1 "List Compact 0" 1 ([] :: [U1Test]) "[]", + testPPrint1 "List Compact 1" 1 [U1Test] "[ U1Test\n]", + testPPrint1 "List Compact 2" 1 [U1Test, U1Test] $ + T.intercalate + "\n" + [ "[ U1Test,", + " U1Test", + "]" + ], + testPPrint1 + "List Compact nested in 1" + 1 + [ [ U1Test, + U1Test + ] + ] + $ T.intercalate + "\n" + [ "[ [ U1Test,", + " U1Test", + " ]", + "]" + ], + testPPrint1 + "List Compact nested in >= 2" + 1 + [ [], + [U1Test], + [ U1Test, + U1Test + ] + ] + $ T.intercalate + "\n" + [ "[ [],", + " [ U1Test", + " ],", + " [ U1Test,", + " U1Test", + " ]", + "]" + ], + testPPrint1 + "List unbounded nested" + 0 + [[], [U1Test], [U1Test, U1Test]] + "[[], [U1Test], [U1Test, U1Test]]" + ], + testGroup + "U1" + [ testPPrint "Unbounded" 0 U1Test "U1Test", + testPPrint "Compact" 1 U1Test "U1Test", + testPPrint "List Compact" 1 [U1Test, U1Test] $ + T.intercalate + "\n" + [ "[ U1Test,", + " U1Test", + "]" + ] + ], + testGroup + "K1[Int]" + [ testPPrint "Unbounded" 0 (K1Test 1) "K1Test 1", + testPPrint "Compact" 1 (K1Test 1) "K1Test\n 1" + ], + testGroup + "K1 U1" + [ testPPrint1 "Unbounded" 0 (K1TestA U1Test) "K1TestA U1Test", + testPPrint1 "Compact" 1 (K1TestA U1Test) "K1TestA\n U1Test" + ], + testGroup + "K1 (K1 Int)" + [ testPPrint1 + "Unbounded" + 0 + (K1TestA (K1Test 1)) + "K1TestA (K1Test 1)", + testPPrint1 "Compact" 1 (K1TestA (K1Test 1)) $ + T.intercalate + "\n" + [ "K1TestA", + " ( K1Test", + " 1", + " )" + ] + ], + testGroup "K1 (I5 (K1 U1) (K1 U1))" $ do + let value = + K1TestA + ( K1TestA + U1Test + :-: K1TestA + U1Test + ) + [ testPPrint1 + "Unbounded" + 0 + value + "K1TestA (K1TestA U1Test :-: K1TestA U1Test)", + testPPrint1 "Compact" 1 value $ + T.intercalate + "\n" + [ "K1TestA", + " ( K1TestA", + " U1Test", + " :-: K1TestA", + " U1Test", + " )" + ] + ], + testGroup "K1 (RecordK1 U1)" $ do + let value = + K1TestA + ( RecordK1TestA + { recordK1TestA = + U1Test + } + ) + [ testPPrint1 + "Unbounded" + 0 + value + "K1TestA (RecordK1TestA {recordK1TestA = U1Test})", + testPPrint1 "Compact" 1 value $ + T.intercalate + "\n" + [ "K1TestA", + " ( RecordK1TestA", + " { recordK1TestA =", + " U1Test", + " }", + " )" + ] + ], + testGroup "K1 (RecordK1 (K1 U1))" $ do + let value = + K1TestA + ( RecordK1TestA + { recordK1TestA = + K1TestA + U1Test + } + ) + [ testPPrint1 + "Unbounded" + 0 + value + "K1TestA (RecordK1TestA {recordK1TestA = K1TestA U1Test})", + testPPrint1 "Compact" 1 value $ + T.intercalate + "\n" + [ "K1TestA", + " ( RecordK1TestA", + " { recordK1TestA =", + " K1TestA", + " U1Test", + " }", + " )" + ] + ], + testGroup "K1 (RecordSum (K1 U1))" $ do + let value = + K1TestA + ( RecordSumTest + { recordSumTest1 = + K1TestA + U1Test, + recordSumTest2 = + K1TestA + U1Test + } + ) + [ testPPrint1 "Unbounded" 0 value $ + "K1TestA (RecordSumTest {recordSumTest1 = K1TestA U1Test, " + <> "recordSumTest2 = K1TestA U1Test})", + testPPrint1 "Compact" 1 value $ + T.intercalate + "\n" + [ "K1TestA", + " ( RecordSumTest", + " { recordSumTest1 =", + " K1TestA", + " U1Test,", + " recordSumTest2 =", + " K1TestA", + " U1Test", + " }", + " )" + ] + ], + testGroup "K1 (K1 U1, K1 U1)" $ do + let value = + K1TestA + ( K1TestA + U1Test, + K1TestA + U1Test + ) + [ testPPrint1 + "Unbounded" + 0 + value + "K1TestA (K1TestA U1Test, K1TestA U1Test)", + testPPrint1 "Compact" 1 value $ + T.intercalate + "\n" + [ "K1TestA", + " ( K1TestA", + " U1Test,", + " K1TestA", + " U1Test", + " )" + ] + ], + testGroup "Sum (K1 U1) (K1 U1)" $ do + let value = SumTestAB (K1TestA U1Test) U1Test + [ testPPrint1 + "Unbounded" + 0 + value + "SumTestAB (K1TestA U1Test) U1Test", + testPPrint1 "Compact" 1 value $ + T.intercalate + "\n" + [ "SumTestAB", + " ( K1TestA", + " U1Test", + " )", + " U1Test" + ] + ], + testGroup "Rec1 K1 (K1 U1)" $ do + let value = + Rec1Test + ( K1TestA + ( K1TestA + U1Test + ) + ) + [ testPPrint1 + "Unbounded" + 0 + value + "Rec1Test (K1TestA (K1TestA U1Test))", + testPPrint1 "Compact" 1 value $ + T.intercalate + "\n" + [ "Rec1Test", + " ( K1TestA", + " ( K1TestA", + " U1Test", + " )", + " )" + ] + ], + testGroup "Comp1 K1 K1 (K1 U1)" $ do + let value = + Comp1Test + ( K1TestA + ( K1TestA + ( K1TestA + U1Test + ) + ) + ) + [ testPPrint1 + "Unbounded" + 0 + value + "Comp1Test (K1TestA (K1TestA (K1TestA U1Test)))", + testPPrint1 "Compact" 1 value $ + T.intercalate + "\n" + [ "Comp1Test", + " ( K1TestA", + " ( K1TestA", + " ( K1TestA", + " U1Test", + " )", + " )", + " )" + ] + ], + testGroup "Comp1 [] [] (K1 U1)" $ do + let value = + Comp1Test + [ [ K1TestA + U1Test, + K1TestA + U1Test + ] + ] + [ testPPrint1 + "Unbounded" + 0 + value + "Comp1Test [[K1TestA U1Test, K1TestA U1Test]]", + testPPrint1 "Compact" 1 value $ + T.intercalate + "\n" + [ "Comp1Test", + " [ [ K1TestA", + " U1Test,", + " K1TestA", + " U1Test", + " ]", + " ]" + ] + ] + ], + testGroup + "PPrint2" + [ testGroup + "Either" + [ testPPrint2 + "Unbounded Left" + 0 + (Left (K1TestA U1Test) :: Either (K1TestA U1Test) ()) + "Left (K1TestA U1Test)", + testPPrint2 + "Unbounded Right" + 0 + (Right (K1TestA U1Test) :: Either () (K1TestA U1Test)) + "Right (K1TestA U1Test)", + testPPrint2 + "Compact Left" + 1 + (Left (K1TestA U1Test) :: Either (K1TestA U1Test) ()) + "Left\n ( K1TestA\n U1Test\n )", + testPPrint2 + "Compact Right" + 1 + (Right (K1TestA U1Test) :: Either () (K1TestA U1Test)) + "Right\n ( K1TestA\n U1Test\n )" + ], + testGroup "(,)" $ do + let value = + (K1TestA U1Test, K1TestA U1Test) :: + (K1TestA U1Test, K1TestA U1Test) + [ testPPrint2 + "Unbounded" + 0 + value + "(K1TestA U1Test, K1TestA U1Test)", + testPPrint2 + "Compact" + 1 + value + "( K1TestA\n U1Test,\n K1TestA\n U1Test\n)" + ] + ], + testGroup + "simple tests" + [ propertyPFormatRead "Bool" (arbitrary :: Gen Bool), + propertyPFormatRead "Integer" (arbitrary :: Gen Integer), + propertyPFormatRead "Int" (arbitrary :: Gen Int), + propertyPFormatRead "Int8" (arbitrary :: Gen Int8), + propertyPFormatRead "Int16" (arbitrary :: Gen Int16), + propertyPFormatRead "Int32" (arbitrary :: Gen Int32), + propertyPFormatRead "Int64" (arbitrary :: Gen Int64), + propertyPFormatRead "Word" (arbitrary :: Gen Word), + propertyPFormatRead "Word8" (arbitrary :: Gen Word8), + propertyPFormatRead "Word16" (arbitrary :: Gen Word16), + propertyPFormatRead "Word32" (arbitrary :: Gen Word32), + propertyPFormatRead "Word64" (arbitrary :: Gen Word64), + propertyPFormatShow + "SomeWordN" + ( oneof + [ SomeWordN <$> (arbitrary :: Gen (WordN 8)), + SomeWordN <$> (arbitrary :: Gen (WordN 9)), + SomeWordN <$> (arbitrary :: Gen (WordN 10)) + ] + ), + propertyPFormatRead "WordN 8" (arbitrary :: Gen (WordN 8)), + propertyPFormatRead "WordN 9" (arbitrary :: Gen (WordN 9)), + propertyPFormatShow + "SomeIntN" + ( oneof + [ SomeIntN <$> (arbitrary :: Gen (IntN 8)), + SomeIntN <$> (arbitrary :: Gen (IntN 9)), + SomeIntN <$> (arbitrary :: Gen (IntN 10)) + ] + ), + propertyPFormatRead "IntN 8" (arbitrary :: Gen (IntN 8)), + propertyPFormatRead "IntN 9" (arbitrary :: Gen (IntN 9)) + ], + testGroup + "Combined types" + [ propertyPFormatRead + "Maybe Maybe" + (arbitrary :: Gen (Maybe (Maybe Int))), + propertyPFormatRead + "Maybe (,)" + ( arbitrary :: Gen (Maybe (Int, Int)) + ), + propertyPFormatRead + "Maybe I5" + ( arbitrary :: Gen (Maybe (I5 Int)) + ), + propertyPFormatRead + "Maybe []" + ( arbitrary :: Gen (Maybe [Int]) + ), + propertyPFormatRead + "Maybe Record" + ( arbitrary :: Gen (Maybe (Record Int Int)) + ), + propertyPFormatRead + "(Maybe,Either)" + ( arbitrary :: Gen (Maybe Int, Either Int Int) + ), + propertyPFormatRead + "((,),(,))" + ( arbitrary :: Gen ((Int, Int), (Int, Int)) + ), + propertyPFormatRead + "(I5,I5)" + ( arbitrary :: Gen (I5 Int, I5 Int) + ), + propertyPFormatRead + "([],[])" + ( arbitrary :: Gen ([Int], [Int]) + ), + propertyPFormatRead + "(Record,Record)" + ( arbitrary :: Gen (Record Int Int, Record Int Int) + ), + propertyPFormatRead "I5 (,)" (arbitrary :: Gen (I5 (Int, Int))), + propertyPFormatRead "I5 I6" (arbitrary :: Gen (I5 (I6 Int))), + propertyPFormatRead "I5 I5" (arbitrary :: Gen (I5 (I5 Int))), + propertyPFormatRead "I6 I5" (arbitrary :: Gen (I6 (I5 Int))), + propertyPFormatRead "I6 I6" (arbitrary :: Gen (I6 (I6 Int))), + propertyPFormatRead "I5 []" (arbitrary :: Gen (I5 [Int])), + propertyPFormatRead + "I5 Record" + (arbitrary :: Gen (I5 (Record Int Int))), + propertyPFormatRead + "[Maybe]" + ( arbitrary :: Gen [Maybe Int] + ), + propertyPFormatRead + "[(,)]" + ( arbitrary :: Gen [(Int, Int)] + ), + propertyPFormatRead "[I5]" (arbitrary :: Gen [I5 Int]), + propertyPFormatRead + "[[]]" + ( arbitrary :: Gen [[Int]] + ), + propertyPFormatRead + "[Record]" + ( arbitrary :: Gen [Record Int Int] + ), + propertyPFormatRead + "Record Maybe Either" + ( arbitrary :: Gen (Record (Maybe Int) (Either Int Int)) + ), + propertyPFormatRead + "Record (,) (,)" + ( arbitrary :: Gen (Record (Int, Int) (Int, Int)) + ), + propertyPFormatRead + "Record I5 I6" + ( arbitrary :: Gen (Record (I5 Int) (I6 Int)) + ), + propertyPFormatRead + "Record []" + ( arbitrary :: Gen (Record [Int] [Int]) + ), + propertyPFormatRead + "Record Record" + ( arbitrary :: Gen (Record (Record Int Int) (Record Int Int)) + ), + propertyPFormatRead + "Maybe (MaybeT Identity Int)" + (Just . MaybeT <$> arbitrary :: Gen (Maybe (MaybeT Identity Int))), + propertyPFormatRead + "Maybe (ExceptT Int Identity Int)" + ( Just . ExceptT <$> arbitrary :: + Gen (Maybe (ExceptT Int Identity Int)) + ), + propertyPFormatRead + "Maybe (LazyWriterT Int Identity Int)" + ( Just . WriterLazy.WriterT <$> arbitrary :: + Gen (Maybe (WriterLazy.WriterT Int Identity Int)) + ), + propertyPFormatRead + "Maybe (StrictWriterT Int Identity Int)" + ( Just . WriterLazy.WriterT <$> arbitrary :: + Gen (Maybe (WriterLazy.WriterT Int Identity Int)) + ), + propertyPFormatRead + "Maybe (IdentityT Identity Int)" + ( Just . IdentityT <$> arbitrary :: + Gen (Maybe (IdentityT Identity Int)) + ), + propertyPFormatRead + "HS.HashSet Int" + (HS.fromList <$> arbitrary :: Gen (HS.HashSet Int)), + propertyPFormatRead + "HM.HashMap Int Int" + (HM.fromList <$> arbitrary :: Gen (HM.HashMap Int Int)) + ], + testGroup + "Symbolic types" + [ testPPrint + "enough space" + 80 + ("a" .&& "b" :: SymBool) + "(&& a b)", + testPPrint + "not enough space" + 6 + ("a" .&& "b" :: SymBool) + "..." + ] + ] diff --git a/test/Grisette/Core/Data/Class/PlainUnionTests.hs b/test/Grisette/Core/Data/Class/PlainUnionTests.hs --- a/test/Grisette/Core/Data/Class/PlainUnionTests.hs +++ b/test/Grisette/Core/Data/Class/PlainUnionTests.hs @@ -9,8 +9,8 @@ LogicalOp ((.&&)), Solvable (con), SymBool, - UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + SymBranching (mrgIfPropagatedStrategy), + Union, mrgIf, mrgSingle, onUnion, @@ -33,7 +33,7 @@ [ testCase "simpleMerge" $ do simpleMerge ( mrgIfPropagatedStrategy "a" (return "b") (return "c") :: - UnionM SymBool + Union SymBool ) @?= symIte "a" "b" "c", testCase "(.#)" $ do @@ -43,7 +43,7 @@ "cond" (return ["a"]) (return ["b", "c"]) :: - UnionM [SymBool] + Union [SymBool] ) @?= symIte "cond" "a" ("b" .&& "c"), testCase "onUnion" $ do @@ -51,35 +51,35 @@ let symAllU = onUnion symAll symAllU ( mrgIfPropagatedStrategy "cond" (return ["a"]) (return ["b", "c"]) :: - UnionM [SymBool] + Union [SymBool] ) @?= symIte "cond" "a" ("b" .&& "c"), testGroup "Single and If pattern" [ testCase "Unmerged" $ case mrgIfPropagatedStrategy "a" (return "b") (return "c") :: - UnionM SymBool of + Union SymBool of Single _ -> fail "Expected If" If c l r -> do c @?= "a" l @?= return "b" r @?= return "c", testCase "Merged" $ - case mrgIf "a" (return "b") (return "c") :: UnionM SymBool of + case mrgIf "a" (return "b") (return "c") :: Union SymBool of If {} -> fail "Expected Single" Single v -> v @?= symIte "a" "b" "c", testCase "Construct single" $ - (Single "a" :: UnionM SymBool) @?= mrgSingle "a", + (Single "a" :: Union SymBool) @?= mrgSingle "a", testCase "Construct If" $ do - let actual = If "a" (return "b") (return "c") :: UnionM SymBool + let actual = If "a" (return "b") (return "c") :: Union SymBool let expected = mrgIf "a" (return "b") (return "c") actual @?= expected ], testCase "overestimateUnionValues" $ do - overestimateUnionValues (return 1 :: UnionM Int) @?= [1] - overestimateUnionValues (mrgIf "a" (return 1) (return 2) :: UnionM Int) + overestimateUnionValues (return 1 :: Union Int) @?= [1] + overestimateUnionValues (mrgIf "a" (return 1) (return 2) :: Union Int) @?= [1, 2 :: Int] overestimateUnionValues - (mrgIf "a" (return 1) (mrgIf "x" (return 3) (return 2)) :: UnionM Int) + (mrgIf "a" (return 1) (mrgIf "x" (return 3) (return 2)) :: Union Int) @?= [1, 2, 3 :: Int] ] diff --git a/test/Grisette/Core/Data/Class/SEqTests.hs b/test/Grisette/Core/Data/Class/SEqTests.hs deleted file mode 100644 --- a/test/Grisette/Core/Data/Class/SEqTests.hs +++ /dev/null @@ -1,720 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Grisette.Core.Data.Class.SEqTests (seqTests) where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import Data.Bifunctor (Bifunctor (bimap)) -import qualified Data.ByteString as B -import Data.Foldable (traverse_) -import Data.Functor.Sum (Sum (InL, InR)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Stack (HasCallStack) -import Generics.Deriving (Default (Default), Generic) -import Grisette - ( LogicalOp (symNot, (.&&)), - SEq ((./=), (.==)), - Solvable (con), - SymBool (SymBool), - ) -import Grisette.Core.Data.Class.TestValues - ( conBool, - ssymBool, - ) -import Grisette.Internal.SymPrim.Prim.Term (pevalEqTerm) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, (@=?)) -import Test.QuickCheck (ioProperty) - -data A = A1 | A2 SymBool | A3 SymBool SymBool - deriving (Generic, Show, Eq) - deriving (SEq) via (Default A) - -concreteSEqOkProp :: (HasCallStack, SEq a, Eq a) => (a, a) -> Assertion -concreteSEqOkProp (i, j) = do - i .== j @=? con (i == j) - i ./= j @=? con (i /= j) - -seqTests :: Test -seqTests = - testGroup - "SEq" - [ testGroup - "SEq for common types" - [ testGroup - "SymBool" - [ testCase "conBool" $ do - let bools :: [Bool] = [True, False] - traverse_ - ( \(i, j) -> - conBool i - .== conBool j - @=? conBool (i == j) - ) - [(x, y) | x <- bools, y <- bools], - testCase "conBool True vs SymBool" $ do - conBool True .== ssymBool "a" @=? ssymBool "a", - testCase "conBool False vs SymBool" $ do - conBool False .== ssymBool "a" @=? symNot (ssymBool "a"), - testCase "SymBool vs conBool True" $ do - ssymBool "a" .== conBool True @=? ssymBool "a", - testCase "SymBool vs conBool False" $ do - ssymBool "a" .== conBool False @=? symNot (ssymBool "a"), - testCase "SymBool vs same SymBool" $ do - ssymBool "a" .== ssymBool "a" @=? conBool True, - testCase "SymBool vs different SymBool" $ do - let SymBool terma = ssymBool "a" - SymBool termb = ssymBool "b" - ssymBool "a" - .== ssymBool "b" - @=? SymBool (pevalEqTerm terma termb) - ], - testProperty "Bool" (ioProperty . concreteSEqOkProp @Bool), - testProperty "Integer" (ioProperty . concreteSEqOkProp @Integer), - testProperty "Char" (ioProperty . concreteSEqOkProp @Char), - testProperty "Int" (ioProperty . concreteSEqOkProp @Int), - testProperty "Int8" (ioProperty . concreteSEqOkProp @Int8), - testProperty "Int16" (ioProperty . concreteSEqOkProp @Int16), - testProperty "Int32" (ioProperty . concreteSEqOkProp @Int32), - testProperty "Int64" (ioProperty . concreteSEqOkProp @Int64), - testProperty "Word" (ioProperty . concreteSEqOkProp @Word), - testProperty "Word8" (ioProperty . concreteSEqOkProp @Word8), - testProperty "Word16" (ioProperty . concreteSEqOkProp @Word16), - testProperty "Word32" (ioProperty . concreteSEqOkProp @Word32), - testProperty "Word64" (ioProperty . concreteSEqOkProp @Word64), - testGroup - "List" - [ testProperty "[Integer]" $ - ioProperty . concreteSEqOkProp @[Integer], - testGroup - "[SymBool]" - [ testCase "Same length 1" $ - [ssymBool "a"] - .== [ssymBool "b"] - @=? ssymBool "a" - .== ssymBool "b", - testCase "Same length 2" $ - [ssymBool "a", ssymBool "b"] - .== [ssymBool "c", ssymBool "d"] - @=? (ssymBool "a" .== ssymBool "c") - .&& (ssymBool "b" .== ssymBool "d"), - testCase "length 1 vs length 0" $ - [ssymBool "a"] .== [] @=? conBool False, - testCase "length 1 vs length 2" $ - [ssymBool "a"] - .== [ssymBool "c", ssymBool "d"] - @=? conBool False - ] - ], - testGroup - "Maybe" - [ testProperty "Maybe Integer" $ - ioProperty . concreteSEqOkProp @(Maybe Integer), - testGroup - "Maybe SymBool" - [ testCase "Nothing vs Nothing" $ - (Nothing :: Maybe SymBool) .== Nothing @=? conBool True, - testCase "Just vs Nothing" $ - Just (ssymBool "a") .== Nothing @=? conBool False, - testCase "Nothing vs Just" $ - Nothing .== Just (ssymBool "a") @=? conBool False, - testCase "Just vs Just" $ - Just (ssymBool "a") - .== Just (ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b" - ] - ], - testGroup - "Either" - [ testProperty "Either" $ - ioProperty . concreteSEqOkProp @(Either Integer Integer), - testGroup - "Either SymBool SymBool" - [ testCase "Left vs Left" $ - (Left (ssymBool "a") :: Either SymBool SymBool) - .== Left (ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b", - testCase "Right vs Left" $ - (Right (ssymBool "a") :: Either SymBool SymBool) - .== Left (ssymBool "b") - @=? conBool False, - testCase "Left vs Right" $ - (Left (ssymBool "a") :: Either SymBool SymBool) - .== Right (ssymBool "b") - @=? conBool False, - testCase "Right vs Right" $ - (Right (ssymBool "a") :: Either SymBool SymBool) - .== Right (ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b" - ] - ], - testGroup - "MaybeT" - [ testProperty "MaybeT" $ - ioProperty - . concreteSEqOkProp @(MaybeT Maybe Integer) - . bimap MaybeT MaybeT, - testGroup - "MaybeT Maybe SymBool" - [ testCase "MaybeT Nothing vs MaybeT Nothing" $ - (MaybeT Nothing :: MaybeT Maybe SymBool) - .== MaybeT Nothing - @=? conBool True, - testCase "MaybeT Nothing vs MaybeT (Just Nothing)" $ - (MaybeT Nothing :: MaybeT Maybe SymBool) - .== MaybeT (Just Nothing) - @=? conBool False, - testCase "MaybeT Nothing vs MaybeT (Just (Just v))" $ - (MaybeT Nothing :: MaybeT Maybe SymBool) - .== MaybeT (Just (Just (ssymBool "a"))) - @=? conBool False, - testCase "MaybeT (Just Nothing) vs MaybeT Nothing" $ - MaybeT (Just Nothing) - .== (MaybeT Nothing :: MaybeT Maybe SymBool) - @=? conBool False, - testCase "MaybeT (Just (Just v)) vs MaybeT Nothing" $ - MaybeT (Just (Just (ssymBool "a"))) - .== (MaybeT Nothing :: MaybeT Maybe SymBool) - @=? conBool False, - testCase "MaybeT (Just Nothing) vs MaybeT (Just Nothing)" $ - MaybeT (Just Nothing) - .== (MaybeT (Just Nothing) :: MaybeT Maybe SymBool) - @=? conBool True, - testCase "MaybeT (Just (Just v)) vs MaybeT (Just Nothing)" $ - MaybeT (Just (Just (ssymBool "a"))) - .== (MaybeT (Just Nothing) :: MaybeT Maybe SymBool) - @=? conBool False, - testCase "MaybeT (Just Nothing) vs MaybeT (Just (Just v))" $ - MaybeT (Just Nothing) - .== ( MaybeT (Just (Just (ssymBool "b"))) :: - MaybeT Maybe SymBool - ) - @=? conBool False, - testCase "MaybeT (Just (Just v)) vs MaybeT (Just (Just v))" $ - MaybeT (Just (Just (ssymBool "a"))) - .== ( MaybeT (Just (Just (ssymBool "b"))) :: - MaybeT Maybe SymBool - ) - @=? ssymBool "a" - .== ssymBool "b" - ] - ], - testGroup - "ExceptT" - [ testProperty "ExceptT Integer Maybe Itneger" $ - ioProperty - . concreteSEqOkProp @(ExceptT Integer Maybe Integer) - . bimap ExceptT ExceptT, - testGroup - "ExceptT SymBool Maybe SymBool" - [ testCase "ExceptT Nothing vs ExceptT Nothing" $ - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .== ExceptT Nothing - @=? conBool True, - testCase "ExceptT Nothing vs ExceptT (Just (Left v))" $ - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .== ExceptT (Just (Left (ssymBool "a"))) - @=? conBool False, - testCase "ExceptT Nothing vs ExceptT (Just (Right v))" $ - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .== ExceptT (Just (Right (ssymBool "a"))) - @=? conBool False, - testCase "ExceptT (Just (Left v)) vs ExceptT Nothing" $ - ExceptT (Just (Left (ssymBool "a"))) - .== (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @=? conBool False, - testCase "ExceptT (Just (Right v)) vs ExceptT Nothing" $ - ExceptT (Just (Right (ssymBool "a"))) - .== (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @=? conBool False, - testCase - "ExceptT (Just (Left v)) vs ExceptT (Just (Left v))" - $ ExceptT (Just (Left (ssymBool "a"))) - .== ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @=? ssymBool "a" - .== ssymBool "b", - testCase - "ExceptT (Just (Right v)) vs ExceptT (Just (Left v))" - $ ExceptT (Just (Right (ssymBool "a"))) - .== ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @=? conBool False, - testCase - "ExceptT (Just (Left v)) vs ExceptT (Just (Right v))" - $ ExceptT (Just (Left (ssymBool "a"))) - .== ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @=? conBool False, - testCase - "ExceptT (Just (Right v)) vs ExceptT (Just (Right v))" - $ ExceptT (Just (Right (ssymBool "a"))) - .== ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @=? ssymBool "a" - .== ssymBool "b" - ] - ], - testProperty "()" (ioProperty . concreteSEqOkProp @()), - testGroup - "(,)" - [ testProperty "(Integer, Integer)" $ - ioProperty . concreteSEqOkProp @(Integer, Integer), - testCase "(SymBool, SymBool)" $ do - (ssymBool "a", ssymBool "c") - .== (ssymBool "b", ssymBool "d") - @=? ssymBool "a" - .== ssymBool "b" - .&& ssymBool "c" - .== ssymBool "d" - ], - testGroup - "(,,)" - [ testProperty "(Integer, Integer, Integer)" $ - ioProperty . concreteSEqOkProp @(Integer, Integer, Integer), - testCase "(SymBool, SymBool, SymBool)" $ - (ssymBool "a", ssymBool "c", ssymBool "e") - .== (ssymBool "b", ssymBool "d", ssymBool "f") - @=? (ssymBool "a" .== ssymBool "b") - .&& ( (ssymBool "c" .== ssymBool "d") - .&& (ssymBool "e" .== ssymBool "f") - ) - ], - testGroup - "(,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteSEqOkProp @(Integer, Integer, Integer, Integer), - testCase "(SymBool, SymBool, SymBool, SymBool)" $ do - (ssymBool "a", ssymBool "c", ssymBool "e", ssymBool "g") - .== (ssymBool "b", ssymBool "d", ssymBool "f", ssymBool "h") - @=? ( (ssymBool "a" .== ssymBool "b") - .&& (ssymBool "c" .== ssymBool "d") - ) - .&& ( (ssymBool "e" .== ssymBool "f") - .&& (ssymBool "g" .== ssymBool "h") - ) - ], - testGroup - "(,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteSEqOkProp - @(Integer, Integer, Integer, Integer, Integer), - testCase "(SymBool, SymBool, SymBool, SymBool, SymBool)" $ do - ( ssymBool "a", - ssymBool "c", - ssymBool "e", - ssymBool "g", - ssymBool "i" - ) - .== ( ssymBool "b", - ssymBool "d", - ssymBool "f", - ssymBool "h", - ssymBool "j" - ) - @=? ( (ssymBool "a" .== ssymBool "b") - .&& (ssymBool "c" .== ssymBool "d") - ) - .&& ( (ssymBool "e" .== ssymBool "f") - .&& ( (ssymBool "g" .== ssymBool "h") - .&& (ssymBool "i" .== ssymBool "j") - ) - ) - ], - testGroup - "(,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteSEqOkProp - @( Integer, - Integer, - Integer, - Integer, - Integer, - Integer - ), - testCase - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - $ ( ssymBool "a", - ssymBool "c", - ssymBool "e", - ssymBool "g", - ssymBool "i", - ssymBool "k" - ) - .== ( ssymBool "b", - ssymBool "d", - ssymBool "f", - ssymBool "h", - ssymBool "j", - ssymBool "l" - ) - @=? ( (ssymBool "a" .== ssymBool "b") - .&& ( (ssymBool "c" .== ssymBool "d") - .&& (ssymBool "e" .== ssymBool "f") - ) - ) - .&& ( (ssymBool "g" .== ssymBool "h") - .&& ( (ssymBool "i" .== ssymBool "j") - .&& (ssymBool "k" .== ssymBool "l") - ) - ) - ], - testGroup - "(,,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteSEqOkProp - @( Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer - ), - testCase - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - $ do - ( ssymBool "a", - ssymBool "c", - ssymBool "e", - ssymBool "g", - ssymBool "i", - ssymBool "k", - ssymBool "m" - ) - .== ( ssymBool "b", - ssymBool "d", - ssymBool "f", - ssymBool "h", - ssymBool "j", - ssymBool "l", - ssymBool "n" - ) - @=? ( (ssymBool "a" .== ssymBool "b") - .&& ( (ssymBool "c" .== ssymBool "d") - .&& (ssymBool "e" .== ssymBool "f") - ) - ) - .&& ( ( (ssymBool "g" .== ssymBool "h") - .&& (ssymBool "i" .== ssymBool "j") - ) - .&& ( (ssymBool "k" .== ssymBool "l") - .&& (ssymBool "m" .== ssymBool "n") - ) - ) - ], - testGroup - "(,,,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteSEqOkProp - @( Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer - ), - testCase - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - $ ( ssymBool "a", - ssymBool "c", - ssymBool "e", - ssymBool "g", - ssymBool "i", - ssymBool "k", - ssymBool "m", - ssymBool "o" - ) - .== ( ssymBool "b", - ssymBool "d", - ssymBool "f", - ssymBool "h", - ssymBool "j", - ssymBool "l", - ssymBool "n", - ssymBool "p" - ) - @=? ( ( (ssymBool "a" .== ssymBool "b") - .&& (ssymBool "c" .== ssymBool "d") - ) - .&& ( (ssymBool "e" .== ssymBool "f") - .&& (ssymBool "g" .== ssymBool "h") - ) - ) - .&& ( ( (ssymBool "i" .== ssymBool "j") - .&& (ssymBool "k" .== ssymBool "l") - ) - .&& ( (ssymBool "m" .== ssymBool "n") - .&& (ssymBool "o" .== ssymBool "p") - ) - ) - ], - testCase "ByteString" $ do - let bytestrings :: [B.ByteString] = ["", "a", "ab"] - traverse_ - (\(i, j) -> i .== j @=? conBool (i == j)) - [(x, y) | x <- bytestrings, y <- bytestrings], - testGroup - "Sum" - [ testProperty "Sum Maybe Maybe Integer" $ - ioProperty - . ( \v -> - let eitherToSum :: - Either (Maybe Integer) (Maybe Integer) -> - Sum Maybe Maybe Integer - eitherToSum (Left x) = InL x - eitherToSum (Right x) = InR x - in concreteSEqOkProp (bimap eitherToSum eitherToSum v) - ), - testGroup - "Sum Maybe Maybe SymBool" - [ testCase "InL (Just v) vs InL (Just v)" $ - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .== InL (Just $ ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b", - testCase "InL (Just v) vs InR (Just v)" $ - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .== InR (Just $ ssymBool "b") - @=? conBool False, - testCase "InR (Just v) vs InR (Just v)" $ - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .== InR (Just $ ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b", - testCase "InR (Just v) vs InL (Just v)" $ - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .== InL (Just $ ssymBool "b") - @=? conBool False - ] - ], - testGroup - "Writer" - [ testGroup - "Lazy" - [ testProperty - "WriterT Integer (Either Integer) Integer" - ( ioProperty - . \( v1 :: Either Integer (Integer, Integer), - v2 :: Either Integer (Integer, Integer) - ) -> - concreteSEqOkProp - ( WriterLazy.WriterT v1, - WriterLazy.WriterT v2 - ) - ), - testGroup - "WriterT SymBool (Either SymBool) SymBool" - [ testCase "WriterT (Left v) vs WriterT (Left v)" $ - ( WriterLazy.WriterT (Left $ ssymBool "a") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .== WriterLazy.WriterT (Left $ ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b", - testCase "WriterT (Left v) vs WriterT (Right v)" $ - ( WriterLazy.WriterT (Left $ ssymBool "a") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .== WriterLazy.WriterT - (Right (ssymBool "b", ssymBool "c")) - @=? conBool False, - testCase "WriterT (Right v) vs WriterT (Left v)" $ - ( WriterLazy.WriterT - (Right (ssymBool "b", ssymBool "c")) :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .== WriterLazy.WriterT (Left $ ssymBool "a") - @=? conBool False, - testCase "WriterT (Right v) vs WriterT (Right v)" $ - ( WriterLazy.WriterT - (Right (ssymBool "a", ssymBool "b")) :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .== WriterLazy.WriterT - (Right (ssymBool "c", ssymBool "d")) - @=? (ssymBool "a" .== ssymBool "c") - .&& (ssymBool "b" .== ssymBool "d") - ] - ], - testGroup - "Strict" - [ testProperty - "WriterT Integer (Either Integer) Integer" - ( ioProperty - . \( v1 :: Either Integer (Integer, Integer), - v2 :: Either Integer (Integer, Integer) - ) -> - concreteSEqOkProp - ( WriterStrict.WriterT v1, - WriterStrict.WriterT v2 - ) - ), - testGroup - "WriterT SymBool (Either SymBool) SymBool" - [ testCase "WriterT (Left v) vs WriterT (Left v)" $ - ( WriterStrict.WriterT (Left $ ssymBool "a") :: - WriterStrict.WriterT - SymBool - (Either SymBool) - SymBool - ) - .== WriterStrict.WriterT (Left $ ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b", - testCase "WriterT (Left v) vs WriterT (Right v)" $ - ( WriterStrict.WriterT (Left $ ssymBool "a") :: - WriterStrict.WriterT - SymBool - (Either SymBool) - SymBool - ) - .== WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "c")) - @=? conBool False, - testCase "WriterT (Right v) vs WriterT (Left v)" $ - ( WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "c")) :: - WriterStrict.WriterT - SymBool - (Either SymBool) - SymBool - ) - .== WriterStrict.WriterT (Left $ ssymBool "a") - @=? conBool False, - testCase "WriterT (Right v) vs WriterT (Right v)" $ - ( WriterStrict.WriterT - (Right (ssymBool "a", ssymBool "b")) :: - WriterStrict.WriterT - SymBool - (Either SymBool) - SymBool - ) - .== WriterStrict.WriterT - (Right (ssymBool "c", ssymBool "d")) - @=? ssymBool "a" - .== ssymBool "c" - .&& ssymBool "b" - .== ssymBool "d" - ] - ] - ], - testGroup - "Identity" - [ testProperty - "Identity Integer" - ( ioProperty . \(v1 :: Integer, v2) -> - concreteSEqOkProp (Identity v1, Identity v2) - ), - testCase "Identity SymBool" $ do - (Identity $ ssymBool "a" :: Identity SymBool) - .== Identity (ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b" - ], - testGroup - "IdentityT" - [ testProperty - "IdentityT (Either Integer) Integer" - ( ioProperty . \(v1 :: Either Integer Integer, v2) -> - concreteSEqOkProp (IdentityT v1, IdentityT v2) - ), - testGroup - "IdentityT (Either SymBool) SymBool" - [ testCase "IdentityT (Left v) vs IdentityT (Left v)" $ - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .== IdentityT (Left $ ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b", - testCase "IdentityT (Left v) vs IdentityT (Right v)" $ - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .== IdentityT (Right $ ssymBool "b") - @=? conBool False, - testCase "IdentityT (Right v) vs IdentityT (Left v)" $ - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .== IdentityT (Left $ ssymBool "b") - @=? conBool False, - testCase "IdentityT (Right v) vs IdentityT (Right v)" $ - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .== IdentityT (Right $ ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b" - ] - ] - ], - testGroup - "deriving SEq for ADT" - [ testGroup - "Simple ADT" - [ testCase "A1 vs A1" $ - A1 .== A1 @=? conBool True, - testCase "A1 vs A2" $ - A1 .== A2 (ssymBool "a") @=? conBool False, - testCase "A1 vs A3" $ - A1 .== A3 (ssymBool "a") (ssymBool "b") @=? conBool False, - testCase "A2 vs A1" $ - A2 (ssymBool "a") .== A1 @=? conBool False, - testCase "A2 vs A2" $ - A2 (ssymBool "a") - .== A2 (ssymBool "b") - @=? ssymBool "a" - .== ssymBool "b", - testCase "A2 vs A3" $ - A2 (ssymBool "a") - .== A3 (ssymBool "b") (ssymBool "c") - @=? conBool False, - testCase "A3 vs A1" $ - A3 (ssymBool "a") (ssymBool "b") .== A1 @=? conBool False, - testCase "A3 vs A2" $ - A3 (ssymBool "a") (ssymBool "b") - .== A2 (ssymBool "c") - @=? conBool False, - testCase "A3 vs A3" $ - A3 (ssymBool "a") (ssymBool "b") - .== A3 (ssymBool "c") (ssymBool "d") - @=? (ssymBool "a" .== ssymBool "c") - .&& (ssymBool "b" .== ssymBool "d") - ] - ] - ] diff --git a/test/Grisette/Core/Data/Class/SOrdTests.hs b/test/Grisette/Core/Data/Class/SOrdTests.hs deleted file mode 100644 --- a/test/Grisette/Core/Data/Class/SOrdTests.hs +++ /dev/null @@ -1,1408 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Grisette.Core.Data.Class.SOrdTests (sordTests) where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import Data.Bifunctor (Bifunctor (bimap)) -import qualified Data.ByteString as B -import Data.Foldable (traverse_) -import Data.Functor.Sum (Sum (InL, InR)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Stack (HasCallStack) -import Grisette - ( ITEOp (symIte), - LogicalOp (symNot, (.&&), (.||)), - SEq ((.==)), - SOrd (symCompare, (.<), (.<=), (.>), (.>=)), - UnionM, - mrgIf, - mrgMax, - mrgMin, - mrgSingle, - symMax, - symMin, - ) -import Grisette.Core.Data.Class.TestValues - ( conBool, - ssymBool, - ) -import Grisette.Lib.Control.Monad (mrgReturn) -import Grisette.SymPrim (SymBool, SymInteger) -import Grisette.TestUtil.SymbolicAssertion ((.@?=)) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, (@?=)) -import Test.QuickCheck (ioProperty) - -concreteOrdOkProp :: (HasCallStack, SOrd a, Ord a) => (a, a) -> Assertion -concreteOrdOkProp (i, j) = do - i .<= j @?= conBool (i <= j) - i .< j @?= conBool (i < j) - i .>= j @?= conBool (i >= j) - i .> j @?= conBool (i > j) - symCompare i j @?= (mrgReturn $ compare i j :: UnionM Ordering) - -symbolicProdOrdOkProp :: - (HasCallStack, Show v, Show vl, Show vr, SOrd v, SOrd vl, SOrd vr) => - v -> - v -> - vl -> - vr -> - vl -> - vr -> - Assertion -symbolicProdOrdOkProp l r ll lr rl rr = do - l .<= r @?= ((ll .< rl) .|| ((ll .== rl) .&& (lr .<= rr))) - l .< r @?= ((ll .< rl) .|| ((ll .== rl) .&& (lr .< rr))) - l .>= r @?= ((ll .> rl) .|| ((ll .== rl) .&& (lr .>= rr))) - l .> r @?= ((ll .> rl) .|| ((ll .== rl) .&& (lr .> rr))) - l - `symCompare` r - @?= ( ( do - lc <- symCompare ll rl - case lc of - EQ -> symCompare lr rr - _ -> mrgReturn lc - ) :: - UnionM Ordering - ) - -sordTests :: Test -sordTests = - testGroup - "SOrd" - [ testGroup - "SOrd for common types" - [ testGroup - "SymBool" - [ testCase "Concrete SymBool" $ do - conBool False .<= conBool False @?= conBool True - conBool False .< conBool False @?= conBool False - conBool False .>= conBool False @?= conBool True - conBool False .> conBool False @?= conBool False - conBool False .<= conBool True @?= conBool True - conBool False .< conBool True @?= conBool True - conBool False .>= conBool True @?= conBool False - conBool False .> conBool True @?= conBool False - conBool True .<= conBool False @?= conBool False - conBool True .< conBool False @?= conBool False - conBool True .>= conBool False @?= conBool True - conBool True .> conBool False @?= conBool True - conBool True .<= conBool True @?= conBool True - conBool True .< conBool True @?= conBool False - conBool True .>= conBool True @?= conBool True - conBool True .> conBool True @?= conBool False, - testCase "Symbolic SymBool" $ do - ssymBool "a" - .<= ssymBool "b" - @?= (symNot (ssymBool "a")) - .|| (ssymBool "b") - ssymBool "a" - .< ssymBool "b" - @?= (symNot (ssymBool "a")) - .&& (ssymBool "b") - ssymBool "a" - .>= ssymBool "b" - @?= (ssymBool "a") - .|| (symNot (ssymBool "b")) - ssymBool "a" - .> ssymBool "b" - @?= (ssymBool "a") - .&& (symNot (ssymBool "b")) - symCompare (ssymBool "a") (ssymBool "b") - @?= ( mrgIf - ((symNot (ssymBool "a")) .&& (ssymBool "b")) - (mrgSingle LT) - ( mrgIf - ((ssymBool "a") .== (ssymBool "b")) - (mrgSingle EQ) - (mrgSingle GT) - ) :: - UnionM Ordering - ) - ], - testProperty "Bool" (ioProperty . concreteOrdOkProp @Bool), - testProperty "Integer" (ioProperty . concreteOrdOkProp @Integer), - testProperty "Char" (ioProperty . concreteOrdOkProp @Char), - testProperty "Int" (ioProperty . concreteOrdOkProp @Int), - testProperty "Int8" (ioProperty . concreteOrdOkProp @Int8), - testProperty "Int16" (ioProperty . concreteOrdOkProp @Int16), - testProperty "Int32" (ioProperty . concreteOrdOkProp @Int32), - testProperty "Int64" (ioProperty . concreteOrdOkProp @Int64), - testProperty "Word" (ioProperty . concreteOrdOkProp @Word), - testProperty "Word8" (ioProperty . concreteOrdOkProp @Word8), - testProperty "Word16" (ioProperty . concreteOrdOkProp @Word16), - testProperty "Word32" (ioProperty . concreteOrdOkProp @Word32), - testProperty "Word64" (ioProperty . concreteOrdOkProp @Word64), - testGroup - "List" - [ testProperty "[Integer]" $ - ioProperty . concreteOrdOkProp @[Integer], - testProperty "[String]" $ - ioProperty . concreteOrdOkProp @[String], - testCase "[SymBool]" $ do - ([] :: [SymBool]) .<= [] @?= conBool True - ([] :: [SymBool]) .< [] @?= conBool False - ([] :: [SymBool]) .>= [] @?= conBool True - ([] :: [SymBool]) .> [] @?= conBool False - ([] :: [SymBool]) - `symCompare` [] - @?= (mrgSingle EQ :: UnionM Ordering) - [] .<= [ssymBool "a"] @?= conBool True - [] .< [ssymBool "a"] @?= conBool True - [] .>= [ssymBool "a"] @?= conBool False - [] .> [ssymBool "a"] @?= conBool False - [] - `symCompare` [ssymBool "a"] - @?= (mrgSingle LT :: UnionM Ordering) - [ssymBool "a"] .<= [] @?= conBool False - [ssymBool "a"] .< [] @?= conBool False - [ssymBool "a"] .>= [] @?= conBool True - [ssymBool "a"] .> [] @?= conBool True - [ssymBool "a"] - `symCompare` [] - @?= (mrgSingle GT :: UnionM Ordering) - - [ssymBool "a", ssymBool "b"] - .<= [ssymBool "c"] - @?= (ssymBool "a" .< ssymBool "c" :: SymBool) - [ssymBool "a", ssymBool "b"] - .< [ssymBool "c"] - @?= (ssymBool "a" .< ssymBool "c" :: SymBool) - [ssymBool "a", ssymBool "b"] - .>= [ssymBool "c"] - @?= ( (ssymBool "a" .> ssymBool "c") - .|| (ssymBool "a" .== ssymBool "c") :: - SymBool - ) - [ssymBool "a", ssymBool "b"] - .> [ssymBool "c"] - @?= ( (ssymBool "a" .> ssymBool "c") - .|| (ssymBool "a" .== ssymBool "c") :: - SymBool - ) - [ssymBool "a"] - `symCompare` [ssymBool "b"] - @?= (ssymBool "a" `symCompare` ssymBool "b" :: UnionM Ordering) - - [ssymBool "a"] - .<= [ssymBool "b", ssymBool "c"] - @?= ( (ssymBool "a" .< ssymBool "b") - .|| (ssymBool "a" .== ssymBool "b") :: - SymBool - ) - [ssymBool "a"] - .< [ssymBool "b", ssymBool "c"] - @?= ( (ssymBool "a" .< ssymBool "b") - .|| (ssymBool "a" .== ssymBool "b") :: - SymBool - ) - [ssymBool "a"] - .>= [ssymBool "b", ssymBool "c"] - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - [ssymBool "a"] - .> [ssymBool "b", ssymBool "c"] - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - [ssymBool "a"] - `symCompare` [ssymBool "b", ssymBool "c"] - @?= ( mrgIf - (ssymBool "a" .< ssymBool "b") - (mrgSingle LT) - ( mrgIf - (ssymBool "a" .== ssymBool "b") - (mrgSingle LT) - (mrgSingle GT) - ) :: - UnionM Ordering - ) - - [ssymBool "a", ssymBool "b"] - .<= [ssymBool "c", ssymBool "d"] - @?= ( (ssymBool "a" .< ssymBool "c") - .|| ( ssymBool "a" - .== ssymBool "c" - .&& ( (ssymBool "b" .< ssymBool "d") - .|| (ssymBool "b" .== ssymBool "d") - ) - ) :: - SymBool - ) - [ssymBool "a", ssymBool "b"] - .< [ssymBool "c", ssymBool "d"] - @?= ( (ssymBool "a" .< ssymBool "c") - .|| ( ssymBool "a" - .== ssymBool "c" - .&& (ssymBool "b" .< ssymBool "d") - ) :: - SymBool - ) - [ssymBool "a", ssymBool "b"] - .>= [ssymBool "c", ssymBool "d"] - @?= ( (ssymBool "a" .> ssymBool "c") - .|| ( ssymBool "a" - .== ssymBool "c" - .&& ( (ssymBool "b" .> ssymBool "d") - .|| (ssymBool "b" .== ssymBool "d") - ) - ) :: - SymBool - ) - [ssymBool "a", ssymBool "b"] - .> [ssymBool "c", ssymBool "d"] - @?= ( (ssymBool "a" .> ssymBool "c") - .|| ( ssymBool "a" - .== ssymBool "c" - .&& (ssymBool "b" .> ssymBool "d") - ) :: - SymBool - ) - [ssymBool "a", ssymBool "b"] - `symCompare` [ssymBool "c", ssymBool "d"] - @?= ( mrgIf - (ssymBool "a" .< ssymBool "c") - (mrgSingle LT) - ( mrgIf - (ssymBool "a" .== ssymBool "c") - (ssymBool "b" `symCompare` ssymBool "d") - (mrgSingle GT) - ) :: - UnionM Ordering - ) - ], - testGroup - "Maybe" - [ testProperty "Maybe Integer" $ - ioProperty . concreteOrdOkProp @(Maybe Integer), - testCase "Maybe SymBool" $ do - (Nothing :: Maybe SymBool) .<= Nothing @?= conBool True - (Nothing :: Maybe SymBool) .< Nothing @?= conBool False - (Nothing :: Maybe SymBool) .>= Nothing @?= conBool True - (Nothing :: Maybe SymBool) .> Nothing @?= conBool False - (Nothing :: Maybe SymBool) - `symCompare` Nothing - @?= (mrgSingle EQ :: UnionM Ordering) - Nothing .<= Just (ssymBool "a") @?= conBool True - Nothing .< Just (ssymBool "a") @?= conBool True - Nothing .>= Just (ssymBool "a") @?= conBool False - Nothing .> Just (ssymBool "a") @?= conBool False - Nothing - `symCompare` Just (ssymBool "a") - @?= (mrgSingle LT :: UnionM Ordering) - Just (ssymBool "a") .<= Nothing @?= conBool False - Just (ssymBool "a") .< Nothing @?= conBool False - Just (ssymBool "a") .>= Nothing @?= conBool True - Just (ssymBool "a") .> Nothing @?= conBool True - Just (ssymBool "a") - `symCompare` Nothing - @?= (mrgSingle GT :: UnionM Ordering) - Just (ssymBool "a") - .<= Just (ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - Just (ssymBool "a") - .< Just (ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - Just (ssymBool "a") - .>= Just (ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - Just (ssymBool "a") - .> Just (ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - Just (ssymBool "a") - `symCompare` Just (ssymBool "b") - @?= ( ssymBool "a" `symCompare` ssymBool "b" :: - UnionM Ordering - ) - ], - testGroup - "MaybeT" - [ testProperty "MaybeT Maybe Integer" $ - ioProperty - . concreteOrdOkProp @(MaybeT Maybe Integer) - . bimap MaybeT MaybeT, - testCase "MaybeT Maybe SymBool" $ do - (MaybeT Nothing :: MaybeT Maybe SymBool) - .<= MaybeT Nothing - @?= conBool True - (MaybeT Nothing :: MaybeT Maybe SymBool) - .<= MaybeT (Just (Just (ssymBool "a"))) - @?= conBool True - MaybeT (Just (Just (ssymBool "a"))) - .<= (MaybeT Nothing :: MaybeT Maybe SymBool) - @?= conBool False - MaybeT (Just (Just (ssymBool "a"))) - .<= ( MaybeT (Just (Just (ssymBool "b"))) :: - MaybeT Maybe SymBool - ) - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - - (MaybeT Nothing :: MaybeT Maybe SymBool) - .< MaybeT Nothing - @?= conBool False - (MaybeT Nothing :: MaybeT Maybe SymBool) - .< MaybeT (Just (Just (ssymBool "a"))) - @?= conBool True - MaybeT (Just (Just (ssymBool "a"))) - .< (MaybeT Nothing :: MaybeT Maybe SymBool) - @?= conBool False - MaybeT (Just (Just (ssymBool "a"))) - .< ( MaybeT (Just (Just (ssymBool "b"))) :: - MaybeT Maybe SymBool - ) - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - - (MaybeT Nothing :: MaybeT Maybe SymBool) - .>= MaybeT Nothing - @?= conBool True - (MaybeT Nothing :: MaybeT Maybe SymBool) - .>= MaybeT (Just (Just (ssymBool "a"))) - @?= conBool False - MaybeT (Just (Just (ssymBool "a"))) - .>= (MaybeT Nothing :: MaybeT Maybe SymBool) - @?= conBool True - MaybeT (Just (Just (ssymBool "a"))) - .>= ( MaybeT (Just (Just (ssymBool "b"))) :: - MaybeT Maybe SymBool - ) - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - - (MaybeT Nothing :: MaybeT Maybe SymBool) - .> MaybeT Nothing - @?= conBool False - (MaybeT Nothing :: MaybeT Maybe SymBool) - .> MaybeT (Just (Just (ssymBool "a"))) - @?= conBool False - MaybeT (Just (Just (ssymBool "a"))) - .> (MaybeT Nothing :: MaybeT Maybe SymBool) - @?= conBool True - MaybeT (Just (Just (ssymBool "a"))) - .> ( MaybeT (Just (Just (ssymBool "b"))) :: - MaybeT Maybe SymBool - ) - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - - (MaybeT Nothing :: MaybeT Maybe SymBool) - `symCompare` MaybeT Nothing - @?= (mrgSingle EQ :: UnionM Ordering) - (MaybeT Nothing :: MaybeT Maybe SymBool) - `symCompare` MaybeT (Just (Just (ssymBool "a"))) - @?= (mrgSingle LT :: UnionM Ordering) - MaybeT (Just (Just (ssymBool "a"))) - `symCompare` (MaybeT Nothing :: MaybeT Maybe SymBool) - @?= (mrgSingle GT :: UnionM Ordering) - MaybeT (Just (Just (ssymBool "a"))) - `symCompare` ( MaybeT (Just (Just (ssymBool "b"))) :: - MaybeT Maybe SymBool - ) - @?= ( ssymBool "a" `symCompare` ssymBool "b" :: - UnionM Ordering - ) - ], - testGroup - "Either" - [ testProperty "Either Integer Integer" $ - ioProperty . concreteOrdOkProp @(Either Integer Integer), - testCase "Either SymBool SymBool" $ do - (Left (ssymBool "a") :: Either SymBool SymBool) - .<= Left (ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - (Left (ssymBool "a") :: Either SymBool SymBool) - .< Left (ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - (Left (ssymBool "a") :: Either SymBool SymBool) - .>= Left (ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - (Left (ssymBool "a") :: Either SymBool SymBool) - .> Left (ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - (Left (ssymBool "a") :: Either SymBool SymBool) - `symCompare` Left (ssymBool "b") - @?= (ssymBool "a" `symCompare` ssymBool "b") - (Left (ssymBool "a") :: Either SymBool SymBool) - .<= Right (ssymBool "b") - @?= conBool True - (Left (ssymBool "a") :: Either SymBool SymBool) - .< Right (ssymBool "b") - @?= conBool True - (Left (ssymBool "a") :: Either SymBool SymBool) - .>= Right (ssymBool "b") - @?= conBool False - (Left (ssymBool "a") :: Either SymBool SymBool) - .> Right (ssymBool "b") - @?= conBool False - (Left (ssymBool "a") :: Either SymBool SymBool) - `symCompare` Right (ssymBool "b") - @?= (mrgSingle LT :: UnionM Ordering) - (Right (ssymBool "a") :: Either SymBool SymBool) - .<= Left (ssymBool "b") - @?= conBool False - (Right (ssymBool "a") :: Either SymBool SymBool) - .< Left (ssymBool "b") - @?= conBool False - (Right (ssymBool "a") :: Either SymBool SymBool) - .>= Left (ssymBool "b") - @?= conBool True - (Right (ssymBool "a") :: Either SymBool SymBool) - .> Left (ssymBool "b") - @?= conBool True - (Right (ssymBool "a") :: Either SymBool SymBool) - `symCompare` Left (ssymBool "b") - @?= (mrgSingle GT :: UnionM Ordering) - (Right (ssymBool "a") :: Either SymBool SymBool) - .<= Right (ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - (Right (ssymBool "a") :: Either SymBool SymBool) - .< Right (ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - (Right (ssymBool "a") :: Either SymBool SymBool) - .>= Right (ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - (Right (ssymBool "a") :: Either SymBool SymBool) - .> Right (ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - (Right (ssymBool "a") :: Either SymBool SymBool) - `symCompare` Right (ssymBool "b") - @?= (ssymBool "a" `symCompare` ssymBool "b") - ], - testGroup - "ExceptT" - [ testProperty - "ExceptT Integer Maybe Integer" - $ ioProperty - . concreteOrdOkProp @(ExceptT Integer Maybe Integer) - . bimap ExceptT ExceptT, - testCase "ExceptT SymBool Maybe SymBool" $ do - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .<= ExceptT Nothing - @?= conBool True - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .<= ExceptT (Just (Left (ssymBool "a"))) - @?= conBool True - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .<= ExceptT (Just (Right (ssymBool "a"))) - @?= conBool True - ExceptT (Just (Left (ssymBool "a"))) - .<= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @?= conBool False - ExceptT (Just (Right (ssymBool "a"))) - .<= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @?= conBool False - ExceptT (Just (Left (ssymBool "a"))) - .<= ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - ExceptT (Just (Right (ssymBool "a"))) - .<= ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= conBool False - ExceptT (Just (Left (ssymBool "a"))) - .<= ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= conBool True - ExceptT (Just (Right (ssymBool "a"))) - .<= ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .< ExceptT Nothing - @?= conBool False - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .< ExceptT (Just (Left (ssymBool "a"))) - @?= conBool True - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .< ExceptT (Just (Right (ssymBool "a"))) - @?= conBool True - ExceptT (Just (Left (ssymBool "a"))) - .< (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @?= conBool False - ExceptT (Just (Right (ssymBool "a"))) - .< (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @?= conBool False - ExceptT (Just (Left (ssymBool "a"))) - .< ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - ExceptT (Just (Right (ssymBool "a"))) - .< ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= conBool False - ExceptT (Just (Left (ssymBool "a"))) - .< ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= conBool True - ExceptT (Just (Right (ssymBool "a"))) - .< ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .>= ExceptT Nothing - @?= conBool True - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .>= ExceptT (Just (Left (ssymBool "a"))) - @?= conBool False - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .>= ExceptT (Just (Right (ssymBool "a"))) - @?= conBool False - ExceptT (Just (Left (ssymBool "a"))) - .>= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @?= conBool True - ExceptT (Just (Right (ssymBool "a"))) - .>= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @?= conBool True - ExceptT (Just (Left (ssymBool "a"))) - .>= ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - ExceptT (Just (Right (ssymBool "a"))) - .>= ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= conBool True - ExceptT (Just (Left (ssymBool "a"))) - .>= ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= conBool False - ExceptT (Just (Right (ssymBool "a"))) - .>= ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .> ExceptT Nothing - @?= conBool False - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .> ExceptT (Just (Left (ssymBool "a"))) - @?= conBool False - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - .> ExceptT (Just (Right (ssymBool "a"))) - @?= conBool False - ExceptT (Just (Left (ssymBool "a"))) - .> (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @?= conBool True - ExceptT (Just (Right (ssymBool "a"))) - .> (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - @?= conBool True - ExceptT (Just (Left (ssymBool "a"))) - .> ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - ExceptT (Just (Right (ssymBool "a"))) - .> ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= conBool True - ExceptT (Just (Left (ssymBool "a"))) - .> ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= conBool False - ExceptT (Just (Right (ssymBool "a"))) - .> ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - `symCompare` ExceptT Nothing - @?= (mrgSingle EQ :: UnionM Ordering) - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - `symCompare` ExceptT (Just (Left (ssymBool "a"))) - @?= (mrgSingle LT :: UnionM Ordering) - (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) - `symCompare` ExceptT (Just (Right (ssymBool "a"))) - @?= (mrgSingle LT :: UnionM Ordering) - ExceptT (Just (Left (ssymBool "a"))) - `symCompare` ( ExceptT Nothing :: - ExceptT SymBool Maybe SymBool - ) - @?= (mrgSingle GT :: UnionM Ordering) - ExceptT (Just (Right (ssymBool "a"))) - `symCompare` ( ExceptT Nothing :: - ExceptT SymBool Maybe SymBool - ) - @?= (mrgSingle GT :: UnionM Ordering) - ExceptT (Just (Left (ssymBool "a"))) - `symCompare` ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (ssymBool "a" `symCompare` ssymBool "b" :: UnionM Ordering) - ExceptT (Just (Right (ssymBool "a"))) - `symCompare` ( ExceptT (Just (Left (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (mrgSingle GT :: UnionM Ordering) - ExceptT (Just (Left (ssymBool "a"))) - `symCompare` ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= (mrgSingle LT :: UnionM Ordering) - ExceptT (Just (Right (ssymBool "a"))) - `symCompare` ( ExceptT (Just (Right (ssymBool "b"))) :: - ExceptT SymBool Maybe SymBool - ) - @?= ( ssymBool "a" `symCompare` ssymBool "b" :: - UnionM Ordering - ) - ], - testProperty "()" (ioProperty . concreteOrdOkProp @()), - testGroup - "(,)" - [ testProperty "(Integer, Integer)" $ - ioProperty . concreteOrdOkProp @(Integer, Integer), - testCase "(SymBool, SymBool)" $ do - let l = (ssymBool "a", ssymBool "c") - let r = (ssymBool "b", ssymBool "d") - let ll = ssymBool "a" - let lr = ssymBool "c" - let rl = ssymBool "b" - let rr = ssymBool "d" - symbolicProdOrdOkProp l r ll lr rl rr - ], - testGroup - "(,,)" - [ testProperty "(Integer, Integer, Integer)" $ - ioProperty . concreteOrdOkProp @(Integer, Integer, Integer), - testCase "(SymBool, SymBool, SymBool)" $ do - let l = (ssymBool "a", ssymBool "c", ssymBool "e") - let r = (ssymBool "b", ssymBool "d", ssymBool "f") - let ll = ssymBool "a" - let lr = (ssymBool "c", ssymBool "e") - let rl = ssymBool "b" - let rr = (ssymBool "d", ssymBool "f") - symbolicProdOrdOkProp l r ll lr rl rr - ], - testGroup - "(,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteOrdOkProp @(Integer, Integer, Integer, Integer), - testCase "(SymBool, SymBool, SymBool, SymBool)" $ do - let l = (ssymBool "a", ssymBool "c", ssymBool "e", ssymBool "g") - let r = (ssymBool "b", ssymBool "d", ssymBool "f", ssymBool "h") - let ll = (ssymBool "a", ssymBool "c") - let lr = (ssymBool "e", ssymBool "g") - let rl = (ssymBool "b", ssymBool "d") - let rr = (ssymBool "f", ssymBool "h") - symbolicProdOrdOkProp l r ll lr rl rr - ], - testGroup - "(,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteOrdOkProp - @(Integer, Integer, Integer, Integer, Integer), - testCase "(SymBool, SymBool, SymBool, SymBool, SymBool)" $ do - let l = - ( ssymBool "a", - ssymBool "c", - ssymBool "e", - ssymBool "g", - ssymBool "i" - ) - let r = - ( ssymBool "b", - ssymBool "d", - ssymBool "f", - ssymBool "h", - ssymBool "j" - ) - let ll = (ssymBool "a", ssymBool "c") - let lr = (ssymBool "e", ssymBool "g", ssymBool "i") - let rl = (ssymBool "b", ssymBool "d") - let rr = (ssymBool "f", ssymBool "h", ssymBool "j") - symbolicProdOrdOkProp l r ll lr rl rr - ], - testGroup - "(,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteOrdOkProp - @( Integer, - Integer, - Integer, - Integer, - Integer, - Integer - ), - testCase - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - $ do - let l = - ( ssymBool "a", - ssymBool "c", - ssymBool "e", - ssymBool "g", - ssymBool "i", - ssymBool "k" - ) - let r = - ( ssymBool "b", - ssymBool "d", - ssymBool "f", - ssymBool "h", - ssymBool "j", - ssymBool "l" - ) - let ll = (ssymBool "a", ssymBool "c", ssymBool "e") - let lr = (ssymBool "g", ssymBool "i", ssymBool "k") - let rl = (ssymBool "b", ssymBool "d", ssymBool "f") - let rr = (ssymBool "h", ssymBool "j", ssymBool "l") - symbolicProdOrdOkProp l r ll lr rl rr - ], - testGroup - "(,,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteOrdOkProp @(Integer, Integer, Integer, Integer, Integer, Integer, Integer), - testCase - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - $ do - let l = - ( ssymBool "a", - ssymBool "c", - ssymBool "e", - ssymBool "g", - ssymBool "i", - ssymBool "k", - ssymBool "m" - ) - let r = - ( ssymBool "b", - ssymBool "d", - ssymBool "f", - ssymBool "h", - ssymBool "j", - ssymBool "l", - ssymBool "n" - ) - let ll = (ssymBool "a", ssymBool "c", ssymBool "e") - let lr = - ( ssymBool "g", - ssymBool "i", - ssymBool "k", - ssymBool "m" - ) - let rl = (ssymBool "b", ssymBool "d", ssymBool "f") - let rr = - ( ssymBool "h", - ssymBool "j", - ssymBool "l", - ssymBool "n" - ) - symbolicProdOrdOkProp l r ll lr rl rr - ], - testGroup - "(,,,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)" - ( ioProperty - . concreteOrdOkProp - @( Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer - ) - ), - testCase - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - $ do - let l = - ( ssymBool "a", - ssymBool "c", - ssymBool "e", - ssymBool "g", - ssymBool "i", - ssymBool "k", - ssymBool "m", - ssymBool "o" - ) - let r = - ( ssymBool "b", - ssymBool "d", - ssymBool "f", - ssymBool "h", - ssymBool "j", - ssymBool "l", - ssymBool "n", - ssymBool "p" - ) - let ll = - ( ssymBool "a", - ssymBool "c", - ssymBool "e", - ssymBool "g" - ) - let lr = - ( ssymBool "i", - ssymBool "k", - ssymBool "m", - ssymBool "o" - ) - let rl = - ( ssymBool "b", - ssymBool "d", - ssymBool "f", - ssymBool "h" - ) - let rr = - ( ssymBool "j", - ssymBool "l", - ssymBool "n", - ssymBool "p" - ) - symbolicProdOrdOkProp l r ll lr rl rr - ], - testGroup - "Sum" - [ testProperty - "Sum Maybe Maybe Integer" - ( ioProperty . \v -> - let eitherToSum :: - Either (Maybe Integer) (Maybe Integer) -> - Sum Maybe Maybe Integer - eitherToSum (Left x) = InL x - eitherToSum (Right x) = InR x - in concreteOrdOkProp (bimap eitherToSum eitherToSum v) - ), - testCase "Sum Maybe Maybe SymBool" $ do - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .<= InL (Just $ ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .< InL (Just $ ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .>= InL (Just $ ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .> InL (Just $ ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .<= InR (Just $ ssymBool "b") - @?= conBool True - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .< InR (Just $ ssymBool "b") - @?= conBool True - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .>= InR (Just $ ssymBool "b") - @?= conBool False - (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .> InR (Just $ ssymBool "b") - @?= conBool False - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .<= InR (Just $ ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .< InR (Just $ ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .>= InR (Just $ ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .> InR (Just $ ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .<= InL (Just $ ssymBool "b") - @?= conBool False - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .< InL (Just $ ssymBool "b") - @?= conBool False - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .>= InL (Just $ ssymBool "b") - @?= conBool True - (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) - .> InL (Just $ ssymBool "b") - @?= conBool True - ], - testGroup - "WriterT" - [ testGroup - "Lazy" - [ testProperty - "WriterT Integer (Either Integer) Integer" - ( ioProperty - . \( v1 :: Either Integer (Integer, Integer), - v2 :: Either Integer (Integer, Integer) - ) -> - concreteOrdOkProp - ( WriterLazy.WriterT v1, - WriterLazy.WriterT v2 - ) - ), - testCase "WriterT SymBool (Either SymBool) SymBool" $ do - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .<= WriterLazy.WriterT (Left $ ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .< WriterLazy.WriterT (Left $ ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .>= WriterLazy.WriterT (Left $ ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .> WriterLazy.WriterT (Left $ ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - `symCompare` WriterLazy.WriterT (Left $ ssymBool "b") - @?= ( ssymBool "a" `symCompare` ssymBool "b" :: - UnionM Ordering - ) - - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .<= WriterLazy.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= conBool True - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .< WriterLazy.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= conBool True - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .>= WriterLazy.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= conBool False - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .> WriterLazy.WriterT (Right (ssymBool "b", ssymBool "d")) - @?= conBool False - ( WriterLazy.WriterT $ Left $ ssymBool "a" :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - `symCompare` WriterLazy.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= (mrgSingle LT :: UnionM Ordering) - - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .<= WriterLazy.WriterT (Left $ ssymBool "b") - @?= conBool False - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .< WriterLazy.WriterT (Left $ ssymBool "b") - @?= conBool False - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .>= WriterLazy.WriterT (Left $ ssymBool "b") - @?= conBool True - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .> WriterLazy.WriterT (Left $ ssymBool "b") - @?= conBool True - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - `symCompare` WriterLazy.WriterT (Left $ ssymBool "b") - @?= (mrgSingle GT :: UnionM Ordering) - - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .<= WriterLazy.WriterT (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - .<= (ssymBool "b", ssymBool "d") :: - SymBool - ) - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .< WriterLazy.WriterT (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - .< (ssymBool "b", ssymBool "d") :: - SymBool - ) - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .>= WriterLazy.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - .>= (ssymBool "b", ssymBool "d") :: - SymBool - ) - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - .> WriterLazy.WriterT (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - .> (ssymBool "b", ssymBool "d") :: - SymBool - ) - ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool - ) - `symCompare` WriterLazy.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - `symCompare` (ssymBool "b", ssymBool "d") :: - UnionM Ordering - ) - ], - testGroup - "Strict" - [ testProperty - "WriterT Integer (Either Integer) Integer" - ( ioProperty - . \( v1 :: Either Integer (Integer, Integer), - v2 :: Either Integer (Integer, Integer) - ) -> - concreteOrdOkProp - ( WriterStrict.WriterT v1, - WriterStrict.WriterT v2 - ) - ), - testCase "WriterT Integer (Either Integer) Integer" $ do - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .<= WriterStrict.WriterT (Left $ ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .< WriterStrict.WriterT (Left $ ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .>= WriterStrict.WriterT (Left $ ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .> WriterStrict.WriterT (Left $ ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - `symCompare` WriterStrict.WriterT (Left $ ssymBool "b") - @?= ( ssymBool "a" `symCompare` ssymBool "b" :: - UnionM Ordering - ) - - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .<= WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= conBool True - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .< WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= conBool True - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .>= WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= conBool False - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .> WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= conBool False - ( WriterStrict.WriterT $ Left $ ssymBool "a" :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - `symCompare` WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= (mrgSingle LT :: UnionM Ordering) - - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .<= WriterStrict.WriterT (Left $ ssymBool "b") - @?= conBool False - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .< WriterStrict.WriterT (Left $ ssymBool "b") - @?= conBool False - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .>= WriterStrict.WriterT (Left $ ssymBool "b") - @?= conBool True - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .> WriterStrict.WriterT (Left $ ssymBool "b") - @?= conBool True - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - `symCompare` WriterStrict.WriterT (Left $ ssymBool "b") - @?= (mrgSingle GT :: UnionM Ordering) - - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .<= WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - .<= (ssymBool "b", ssymBool "d") :: - SymBool - ) - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .< WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - .< (ssymBool "b", ssymBool "d") :: - SymBool - ) - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .>= WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - .>= (ssymBool "b", ssymBool "d") :: - SymBool - ) - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - .> WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - .> (ssymBool "b", ssymBool "d") :: - SymBool - ) - ( WriterStrict.WriterT $ - Right (ssymBool "a", ssymBool "c") :: - WriterStrict.WriterT SymBool (Either SymBool) SymBool - ) - `symCompare` WriterStrict.WriterT - (Right (ssymBool "b", ssymBool "d")) - @?= ( (ssymBool "a", ssymBool "c") - `symCompare` (ssymBool "b", ssymBool "d") :: - UnionM Ordering - ) - ] - ], - testGroup - "Identity" - [ testProperty - "Identity Integer" - ( ioProperty . \(v1 :: Integer, v2) -> - concreteOrdOkProp (Identity v1, Identity v2) - ), - testCase "Identity SymBool" $ do - (Identity $ ssymBool "a" :: Identity SymBool) - .<= Identity (ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - (Identity $ ssymBool "a" :: Identity SymBool) - .< Identity (ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - (Identity $ ssymBool "a" :: Identity SymBool) - .>= Identity (ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - (Identity $ ssymBool "a" :: Identity SymBool) - .> Identity (ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - ], - testGroup - "IdentityT" - [ testProperty - "IdentityT (Either Integer) Integer" - ( ioProperty . \(v1 :: Either Integer Integer, v2) -> - concreteOrdOkProp (IdentityT v1, IdentityT v2) - ), - testCase "IdentityT (Either SymBool) SymBool" $ do - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .<= IdentityT (Left $ ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .< IdentityT (Left $ ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .>= IdentityT (Left $ ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .> IdentityT (Left $ ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - `symCompare` IdentityT (Left $ ssymBool "b") - @?= (ssymBool "a" `symCompare` ssymBool "b") - - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .<= IdentityT (Right $ ssymBool "b") - @?= conBool True - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .< IdentityT (Right $ ssymBool "b") - @?= conBool True - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .>= IdentityT (Right $ ssymBool "b") - @?= conBool False - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .> IdentityT (Right $ ssymBool "b") - @?= conBool False - ( IdentityT $ Left $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - `symCompare` IdentityT (Right $ ssymBool "b") - @?= (mrgSingle LT :: UnionM Ordering) - - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .<= IdentityT (Left $ ssymBool "b") - @?= conBool False - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .< IdentityT (Left $ ssymBool "b") - @?= conBool False - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .>= IdentityT (Left $ ssymBool "b") - @?= conBool True - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .> IdentityT (Left $ ssymBool "b") - @?= conBool True - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - `symCompare` IdentityT (Left $ ssymBool "b") - @?= (mrgSingle GT :: UnionM Ordering) - - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .<= IdentityT (Right $ ssymBool "b") - @?= (ssymBool "a" .<= ssymBool "b" :: SymBool) - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .< IdentityT (Right $ ssymBool "b") - @?= (ssymBool "a" .< ssymBool "b" :: SymBool) - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .>= IdentityT (Right $ ssymBool "b") - @?= (ssymBool "a" .>= ssymBool "b" :: SymBool) - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - .> IdentityT (Right $ ssymBool "b") - @?= (ssymBool "a" .> ssymBool "b" :: SymBool) - ( IdentityT $ Right $ ssymBool "a" :: - IdentityT (Either SymBool) SymBool - ) - `symCompare` IdentityT (Right $ ssymBool "b") - @?= (ssymBool "a" `symCompare` ssymBool "b") - ], - testCase "ByteString" $ do - let bytestrings :: [B.ByteString] = - ["", "a", "b", "ab", "ba", "aa", "bb"] - traverse_ - concreteOrdOkProp - [(x, y) | x <- bytestrings, y <- bytestrings] - ], - testCase "symMax" $ do - symMax (1 :: SymInteger) 2 @?= 2 - let [a, b] = ["a", "b"] :: [SymInteger] - symMax a b .@?= symIte (a .>= b) a b, - testCase "symMin" $ do - symMin (1 :: SymInteger) 2 @?= 1 - let [a, b] = ["a", "b"] :: [SymInteger] - symMin a b .@?= symIte (a .>= b) b a, - testCase "mrgMax" $ do - mrgMax [1] [0, 3] @?= (mrgReturn [1] :: UnionM [SymInteger]) - let [a, b, c] = ["a", "b", "c"] :: [SymInteger] - (mrgMax [a] [b, c] :: UnionM [SymInteger]) - .@?= (mrgIf (a .<= b) (return [b, c]) (return [a])), - testCase "mrgMin" $ do - mrgMin [1] [0, 3] @?= (mrgReturn [0, 3] :: UnionM [SymInteger]) - let [a, b, c] = ["a", "b", "c"] :: [SymInteger] - (mrgMin [a] [b, c] :: UnionM [SymInteger]) - .@?= (mrgIf (b .< a) (return [b, c]) (return [a])) - ] diff --git a/test/Grisette/Core/Data/Class/SafeDivisionTests.hs b/test/Grisette/Core/Data/Class/SafeDivisionTests.hs --- a/test/Grisette/Core/Data/Class/SafeDivisionTests.hs +++ b/test/Grisette/Core/Data/Class/SafeDivisionTests.hs @@ -24,13 +24,13 @@ SafeDivision (safeDiv, safeDivMod, safeMod, safeQuot, safeQuotRem, safeRem), SomeIntN, SomeWordN, - UnionM, + Union, WordN, mrgPure, pattern SomeIntN, pattern SomeWordN, ) -import Grisette.Internal.Core.Control.Monad.UnionM (isMerged) +import Grisette.Internal.Core.Control.Monad.Union (isMerged) import Grisette.Lib.Control.Monad.Except (mrgThrowError) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) @@ -43,7 +43,7 @@ (t -> t') -> (r -> r') -> (ArithException -> e) -> - (t' -> t' -> ExceptT e UnionM r') -> + (t' -> t' -> ExceptT e Union r') -> (t -> t -> r) -> t -> t -> @@ -73,7 +73,7 @@ (r -> r') -> (ArithException -> e) -> String -> - (t' -> t' -> ExceptT e UnionM r') -> + (t' -> t' -> ExceptT e Union r') -> (t -> t -> r) -> Test generalOpTestBase wrapInput wrapOutput wrapError name f fref = @@ -88,7 +88,7 @@ generalOpTest :: (NFData r, Arbitrary t, Show t, Eq r, Show r, Eq r, Num t, Mergeable r) => String -> - (t -> t -> ExceptT ArithException UnionM r) -> + (t -> t -> ExceptT ArithException Union r) -> (t -> t -> r) -> Test generalOpTest = generalOpTestBase id id id @@ -110,7 +110,7 @@ (r -> r') -> (ArithException -> e) -> String -> - (t' -> t' -> ExceptT e UnionM r') -> + (t' -> t' -> ExceptT e Union r') -> (t -> t -> r) -> Test opBoundedTestBase wrapInput wrapOutput wrapError name f fref = @@ -135,7 +135,7 @@ Mergeable r ) => String -> - (t -> t -> ExceptT ArithException UnionM r) -> + (t -> t -> ExceptT ArithException Union r) -> (t -> t -> r) -> Test opBoundedTest = opBoundedTestBase id id id @@ -144,7 +144,7 @@ forall r. (Eq r, Show r, Eq r, NFData r, Mergeable r) => String -> - (t -> t -> ExceptT ArithException UnionM r) -> + (t -> t -> ExceptT ArithException Union r) -> (t -> t -> r) -> Test @@ -152,7 +152,7 @@ forall t. ( NFData t, Show t, - SafeDivision ArithException t (ExceptT ArithException UnionM), + SafeDivision ArithException t (ExceptT ArithException Union), Mergeable t, Integral t, Typeable t @@ -175,7 +175,7 @@ -- forall r r'. -- (Eq r, Show r, Eq r, NFData r, Mergeable r) => -- String -> --- (t' -> t' -> ExceptT ArithException UnionM r') -> +-- (t' -> t' -> ExceptT ArithException Union r') -> -- (t -> t -> r) -> -- Test -- @@ -183,7 +183,7 @@ -- forall t t'. -- ( NFData t, -- Show t, --- SafeDivision ArithException t' (ExceptT ArithException UnionM), +-- SafeDivision ArithException t' (ExceptT ArithException Union), -- Mergeable t, -- Integral t, -- Typeable t' @@ -243,7 +243,7 @@ safeDiv (bv 10 2) (bv 11 3) :: ExceptT (Either BitwidthMismatch ArithException) - UnionM + Union SomeWordN let expected = mrgThrowError $ Left BitwidthMismatch actual @?= expected @@ -270,7 +270,7 @@ safeDiv (bv 10 2) (bv 11 3) :: ExceptT (Either BitwidthMismatch ArithException) - UnionM + Union SomeIntN let expected = mrgThrowError $ Left BitwidthMismatch actual @?= expected diff --git a/test/Grisette/Core/Data/Class/SafeLinearArithTests.hs b/test/Grisette/Core/Data/Class/SafeLinearArithTests.hs --- a/test/Grisette/Core/Data/Class/SafeLinearArithTests.hs +++ b/test/Grisette/Core/Data/Class/SafeLinearArithTests.hs @@ -24,7 +24,7 @@ SomeIntN, SomeWordN, TryMerge, - UnionM, + Union, WordN, mrgSingle, pattern SomeIntN, @@ -81,7 +81,7 @@ safeLinearArithTest :: forall a b e. - ( SafeLinearArith e b (ExceptT e UnionM), + ( SafeLinearArith e b (ExceptT e Union), Integral a, Bounded a, Arbitrary a, @@ -103,20 +103,20 @@ [ testProperty "safeAdd" $ \(l :: a) (r :: a) -> ioProperty $ do let actual = safeAdd (wrap l) (wrap r) let expected = mrgModifyError transformError $ binSafeOp (+) l r - actual @?= (mrgFmap wrap expected :: ExceptT e UnionM b), + actual @?= (mrgFmap wrap expected :: ExceptT e Union b), testProperty "safeSub" $ \(l :: a) (r :: a) -> ioProperty $ do let actual = safeSub (wrap l) (wrap r) let expected = mrgModifyError transformError $ binSafeOp (-) l r - actual @?= (mrgFmap wrap expected :: ExceptT e UnionM b), + actual @?= (mrgFmap wrap expected :: ExceptT e Union b), testProperty "safeNeg" $ \(l :: a) -> ioProperty $ do - let actual = safeNeg (wrap l) :: ExceptT e UnionM b + let actual = safeNeg (wrap l) :: ExceptT e Union b let expected = mrgModifyError transformError $ unarySafeOp negate l actual @?= mrgFmap wrap expected ] safeLinearArithTestSimple :: forall a. - ( SafeLinearArith ArithException a (ExceptT ArithException UnionM), + ( SafeLinearArith ArithException a (ExceptT ArithException Union), Integral a, Bounded a, Arbitrary a, @@ -155,7 +155,7 @@ let r = bv 3 1 :: SomeIntN let actual = safeAdd l r :: - ExceptT (Either BitwidthMismatch ArithException) UnionM SomeIntN + ExceptT (Either BitwidthMismatch ArithException) Union SomeIntN let expected = mrgThrowError $ Left BitwidthMismatch actual @?= expected, safeLinearArithTestSimple @Word, @@ -184,7 +184,7 @@ safeAdd l r :: ExceptT (Either BitwidthMismatch ArithException) - UnionM + Union SomeWordN let expected = mrgThrowError $ Left BitwidthMismatch actual @?= expected diff --git a/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs b/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs --- a/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs +++ b/test/Grisette/Core/Data/Class/SafeSymRotateTests.hs @@ -22,7 +22,7 @@ Solvable (con), SymIntN, SymWordN, - UnionM, + Union, WordN, ) import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) @@ -36,7 +36,7 @@ import Test.QuickCheck.Gen (chooseInt) import Test.QuickCheck.Property (forAll) -type EM = ExceptT ArithException UnionM +type EM = ExceptT ArithException Union overflowError :: (Mergeable a) => EM a overflowError = mrgThrowError Overflow diff --git a/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs b/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs --- a/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs +++ b/test/Grisette/Core/Data/Class/SafeSymShiftTests.hs @@ -24,7 +24,7 @@ Solvable (con), SymIntN, SymWordN, - UnionM, + Union, WordN, ) import Grisette.Internal.SymPrim.Prim.Term (LinkedRep) @@ -38,7 +38,7 @@ import Test.QuickCheck.Gen (chooseInt) import Test.QuickCheck.Property (forAll) -type EM = ExceptT ArithException UnionM +type EM = ExceptT ArithException Union overflowError :: (Mergeable a) => EM a overflowError = mrgThrowError Overflow diff --git a/test/Grisette/Core/Data/Class/SimpleMergeableTests.hs b/test/Grisette/Core/Data/Class/SimpleMergeableTests.hs --- a/test/Grisette/Core/Data/Class/SimpleMergeableTests.hs +++ b/test/Grisette/Core/Data/Class/SimpleMergeableTests.hs @@ -32,7 +32,7 @@ Mergeable, SimpleMergeable (mrgIte), SymBool, - UnionM, + Union, mrgIf, mrgIte1, mrgSingle, @@ -203,22 +203,22 @@ (ssymBool "a") (symNot $ ssymBool "c") ((ssymBool "b") .&& (ssymBool "c")), - testCase "MaybeT (UnionM) SymBool" $ do - let l :: MaybeT (UnionM) SymBool = + testCase "MaybeT (Union) SymBool" $ do + let l :: MaybeT (Union) SymBool = MaybeT ( mrgIf (ssymBool "b") (mrgSingle Nothing) (mrgSingle $ Just $ ssymBool "c") ) - let r :: MaybeT (UnionM) SymBool = + let r :: MaybeT (Union) SymBool = MaybeT ( mrgIf (ssymBool "d") (mrgSingle Nothing) (mrgSingle $ Just $ ssymBool "e") ) - let res :: MaybeT (UnionM) SymBool = + let res :: MaybeT (Union) SymBool = MaybeT ( mrgIf (ssymBool "a") @@ -236,8 +236,8 @@ mrgIte (ssymBool "a") l r @?= res mrgIte1 (ssymBool "a") l r @?= res mrgIf (ssymBool "a") l r @?= res, - testCase "ExceptT SymBool (UnionM) SymBool" $ do - let l :: ExceptT SymBool (UnionM) SymBool = + testCase "ExceptT SymBool (Union) SymBool" $ do + let l :: ExceptT SymBool (Union) SymBool = ExceptT ( mrgIf (ssymBool "b") @@ -270,12 +270,12 @@ mrgIte1 (ssymBool "a") l r @?= res mrgIf (ssymBool "a") l r @?= res, testGroup - "StateT Integer (UnionM) SymBool" + "StateT Integer (Union) SymBool" [ testCase "Lazy" $ do - let st1 :: StateLazy.StateT Integer (UnionM) SymBool = + let st1 :: StateLazy.StateT Integer (Union) SymBool = StateLazy.StateT $ \(x :: Integer) -> mrgSingle (ssymBool "a", x + 2) - let st2 :: StateLazy.StateT Integer (UnionM) SymBool = + let st2 :: StateLazy.StateT Integer (Union) SymBool = StateLazy.StateT $ \(x :: Integer) -> mrgSingle (ssymBool "b", x * 2) let st3 = mrgIte (ssymBool "c") st1 st2 @@ -306,10 +306,10 @@ (mrgSingle (ssymBool "a", 5)) (mrgSingle (ssymBool "b", 6)), testCase "Strict" $ do - let st1 :: StateStrict.StateT Integer (UnionM) SymBool = + let st1 :: StateStrict.StateT Integer (Union) SymBool = StateStrict.StateT $ \(x :: Integer) -> mrgSingle (ssymBool "a", x + 2) - let st2 :: StateStrict.StateT Integer (UnionM) SymBool = + let st2 :: StateStrict.StateT Integer (Union) SymBool = StateStrict.StateT $ \(x :: Integer) -> mrgSingle (ssymBool "b", x * 2) let st3 = mrgIte (ssymBool "c") st1 st2 @@ -340,10 +340,10 @@ (mrgSingle (ssymBool "a", 5)) (mrgSingle (ssymBool "b", 6)) ], - testCase "ContT (SymBool, Integer) (UnionM) (SymBool, Integer)" $ do - let c1 :: ContT (SymBool, Integer) (UnionM) (SymBool, Integer) = + testCase "ContT (SymBool, Integer) (Union) (SymBool, Integer)" $ do + let c1 :: ContT (SymBool, Integer) (Union) (SymBool, Integer) = ContT $ \f -> f (ssymBool "a", 2) - let c2 :: ContT (SymBool, Integer) (UnionM) (SymBool, Integer) = + let c2 :: ContT (SymBool, Integer) (Union) (SymBool, Integer) = ContT $ \f -> f (ssymBool "b", 3) let c3 = mrgIte (ssymBool "c") c1 c2 let c3u1 = mrgIf (ssymBool "c") c1 c2 @@ -364,18 +364,19 @@ mrgIf (ssymBool "p") (mrgSingle (a, x)) - (mrgSingle (symNot a, x + 1)) + (mrgSingle (symNot a, x + 1)) :: + Union (SymBool, Integer) runContT c3 f @?= r runContT c3u1 f @?= r, testGroup - "RWST (Integer, SymBool) (Monoid.Sum Integer, AndMonoidSymBool) (Integer, SymBool) (UnionM) (Integer, SymBool)" + "RWST (Integer, SymBool) (Monoid.Sum Integer, AndMonoidSymBool) (Integer, SymBool) (Union) (Integer, SymBool)" [ testCase "Lazy" $ do let rws1 :: RWSTLazy.RWST (Integer, SymBool) (Monoid.Sum Integer, AndMonoidSymBool) (Integer, SymBool) - (UnionM) + (Union) (Integer, SymBool) = RWSTLazy.RWST $ \(ir, br) (is, bs) -> mrgSingle @@ -390,7 +391,7 @@ (Integer, SymBool) (Monoid.Sum Integer, AndMonoidSymBool) (Integer, SymBool) - (UnionM) + (Union) (Integer, SymBool) = RWSTLazy.RWST $ \(ir, br) (is, bs) -> mrgSingle @@ -404,7 +405,7 @@ let rws3u1 = mrgIf (ssymBool "c") rws1 rws2 let res1 :: - UnionM + Union ( (Integer, SymBool), (Integer, SymBool), (Monoid.Sum Integer, AndMonoidSymBool) @@ -439,7 +440,7 @@ (Integer, SymBool) (Monoid.Sum Integer, AndMonoidSymBool) (Integer, SymBool) - (UnionM) + (Union) (Integer, SymBool) = RWSTStrict.RWST $ \(ir, br) (is, bs) -> mrgSingle @@ -454,7 +455,7 @@ (Integer, SymBool) (Monoid.Sum Integer, AndMonoidSymBool) (Integer, SymBool) - (UnionM) + (Union) (Integer, SymBool) = RWSTStrict.RWST $ \(ir, br) (is, bs) -> mrgSingle @@ -468,7 +469,7 @@ let rws3u1 = mrgIf (ssymBool "c") rws1 rws2 let res1 :: - UnionM + Union ( (Integer, SymBool), (Integer, SymBool), (Monoid.Sum Integer, AndMonoidSymBool) @@ -499,24 +500,24 @@ @?= res1 ], testGroup - "WriterT (Monoid.Sum Integer) (UnionM) SymBool" + "WriterT (Monoid.Sum Integer) (Union) SymBool" [ testCase "Lazy" $ do let st1 :: WriterLazy.WriterT (Monoid.Sum Integer) - (UnionM) + (Union) SymBool = WriterLazy.WriterT $ mrgSingle (ssymBool "a", 1) let st2 :: WriterLazy.WriterT (Monoid.Sum Integer) - (UnionM) + (Union) SymBool = WriterLazy.WriterT $ mrgSingle (ssymBool "b", 2) let st3 :: WriterLazy.WriterT (Monoid.Sum Integer) - (UnionM) + (Union) SymBool = WriterLazy.WriterT $ mrgSingle (ssymBool "c", 1) let st4 = mrgIte (ssymBool "d") st1 st2 @@ -553,19 +554,19 @@ let st1 :: WriterStrict.WriterT (Monoid.Sum Integer) - (UnionM) + (Union) SymBool = WriterStrict.WriterT $ mrgSingle (ssymBool "a", 1) let st2 :: WriterStrict.WriterT (Monoid.Sum Integer) - (UnionM) + (Union) SymBool = WriterStrict.WriterT $ mrgSingle (ssymBool "b", 2) let st3 :: WriterStrict.WriterT (Monoid.Sum Integer) - (UnionM) + (Union) SymBool = WriterStrict.WriterT $ mrgSingle (ssymBool "c", 1) let st4 = mrgIte (ssymBool "d") st1 st2 @@ -599,10 +600,10 @@ @?= mrgSingle (symIte (ssymBool "d") (ssymBool "a") (ssymBool "c"), 1) ], - testCase "ReaderT Integer (UnionM) Integer" $ do - let r1 :: ReaderT Integer (UnionM) Integer = + testCase "ReaderT Integer (Union) Integer" $ do + let r1 :: ReaderT Integer (Union) Integer = ReaderT $ \(x :: Integer) -> mrgSingle $ x + 2 - let r2 :: ReaderT Integer (UnionM) Integer = + let r2 :: ReaderT Integer (Union) Integer = ReaderT $ \(x :: Integer) -> mrgSingle $ x * 2 let r3 = mrgIte (ssymBool "c") r1 r2 let r3u1 = mrgIf (ssymBool "c") r1 r2 @@ -615,9 +616,9 @@ (mrgSingle 5) (mrgSingle 6) - let r4 :: ReaderT SymBool (UnionM) SymBool = + let r4 :: ReaderT SymBool (Union) SymBool = ReaderT $ \x -> mrgSingle $ x .&& ssymBool "x" - let r5 :: ReaderT SymBool (UnionM) SymBool = + let r5 :: ReaderT SymBool (Union) SymBool = ReaderT $ \x -> mrgSingle $ x .|| ssymBool "y" let r61 = mrgIte1 (ssymBool "c") r4 r5 runReaderT r61 (ssymBool "a") @@ -635,10 +636,10 @@ runIdentity i3 @?= symIte (ssymBool "c") (ssymBool "a") (ssymBool "b") runIdentity i31 @?= symIte (ssymBool "c") (ssymBool "a") (ssymBool "b"), - testCase "IdentityT (UnionM) SymBool" $ do - let i1 :: IdentityT (UnionM) SymBool = + testCase "IdentityT (Union) SymBool" $ do + let i1 :: IdentityT (Union) SymBool = IdentityT $ mrgSingle $ ssymBool "a" - let i2 :: IdentityT (UnionM) SymBool = + let i2 :: IdentityT (Union) SymBool = IdentityT $ mrgSingle $ ssymBool "b" let i3 = mrgIte (ssymBool "c") i1 i2 let i31 = mrgIte1 (ssymBool "c") i1 i2 diff --git a/test/Grisette/Core/Data/Class/SubstSymTests.hs b/test/Grisette/Core/Data/Class/SubstSymTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/SubstSymTests.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Core.Data.Class.SubstSymTests (substSymTests) where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import qualified Data.ByteString as B +import Data.Functor.Sum (Sum (InL, InR)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Stack (HasCallStack) +import Grisette (LogicalOp ((.||)), SubstSym (substSym), SymBool) +import Grisette.Core.Data.Class.TestValues (ssymBool, ssymbolBool) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, (@?=)) +import Test.QuickCheck (ioProperty) + +concreteSubstSymOkProp :: + (HasCallStack, SubstSym a, Show a, Eq a) => a -> Assertion +concreteSubstSymOkProp x = + substSym (ssymbolBool "a") (ssymBool "b") x @?= x + +substSymTests :: Test +substSymTests = + testGroup + "SubstSym" + [ testGroup + "SubstSym for common types" + [ testCase "SymBool" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst = substSym asym b + subst a @?= b + subst c @?= c + subst (a .|| c) @?= b .|| c, + testProperty "Bool" $ ioProperty . concreteSubstSymOkProp @Bool, + testProperty "Integer" $ + ioProperty . concreteSubstSymOkProp @Integer, + testProperty "Char" $ ioProperty . concreteSubstSymOkProp @Char, + testProperty "Int" $ ioProperty . concreteSubstSymOkProp @Int, + testProperty "Int8" $ ioProperty . concreteSubstSymOkProp @Int8, + testProperty "Int16" $ + ioProperty . concreteSubstSymOkProp @Int16, + testProperty "Int32" $ + ioProperty . concreteSubstSymOkProp @Int32, + testProperty "Int64" $ + ioProperty . concreteSubstSymOkProp @Int64, + testProperty "Word" $ ioProperty . concreteSubstSymOkProp @Word, + testProperty "Word8" $ + ioProperty . concreteSubstSymOkProp @Word8, + testProperty "Word16" $ + ioProperty . concreteSubstSymOkProp @Word16, + testProperty "Word32" $ + ioProperty . concreteSubstSymOkProp @Word32, + testProperty "Word64" $ + ioProperty . concreteSubstSymOkProp @Word64, + testGroup + "List" + [ testProperty "[Integer]" $ + ioProperty . concreteSubstSymOkProp @[Integer], + testCase "[SymBool]" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst = substSym asym b + subst [a, c] @?= [b, c] + ], + testGroup + "Maybe" + [ testProperty "Maybe Integer" $ + ioProperty . concreteSubstSymOkProp @(Maybe Integer), + testCase "Maybe SymBool" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst :: Maybe SymBool -> Maybe SymBool + subst = substSym asym b + subst (Just a) @?= Just b + subst (Just c) @?= Just c + subst Nothing @?= Nothing + ], + testGroup + "Either" + [ testProperty "Either Integer Integer" $ + ioProperty + . concreteSubstSymOkProp @(Either Integer Integer), + testCase "Either SymBool SymBool" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst :: Either SymBool SymBool -> Either SymBool SymBool + subst = substSym asym b + subst (Left a) @?= Left b + subst (Left c) @?= Left c + subst (Right a) @?= Right b + subst (Right c) @?= Right c + ], + testGroup + "MaybeT" + [ testProperty "MaybeT Maybe Integer" $ + ioProperty + . concreteSubstSymOkProp @(MaybeT Maybe Integer) + . MaybeT, + testCase "MaybeT Maybe SymBool" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst :: MaybeT Maybe SymBool -> MaybeT Maybe SymBool + subst = substSym asym b + subst (MaybeT Nothing) @?= MaybeT Nothing + subst (MaybeT (Just Nothing)) @?= MaybeT (Just Nothing) + subst (MaybeT (Just (Just a))) @?= MaybeT (Just (Just b)) + subst (MaybeT (Just (Just c))) @?= MaybeT (Just (Just c)) + ], + testGroup + "ExceptT" + [ testProperty "ExceptT Maybe Integer" $ + ioProperty + . concreteSubstSymOkProp @(ExceptT Integer Maybe Integer) + . ExceptT, + testCase "ExceptT SymBool Maybe SymBool" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst :: + ExceptT SymBool Maybe SymBool -> + ExceptT SymBool Maybe SymBool + subst = substSym asym b + subst (ExceptT Nothing) @?= ExceptT Nothing + subst (ExceptT $ Just $ Left a) @?= ExceptT (Just $ Left b) + subst (ExceptT $ Just $ Left c) @?= ExceptT (Just $ Left c) + subst (ExceptT $ Just $ Right a) @?= ExceptT (Just $ Right b) + subst (ExceptT $ Just $ Right c) @?= ExceptT (Just $ Right c) + ], + testProperty "()" (ioProperty . concreteSubstSymOkProp @()), + testGroup + "(,)" + [ testProperty "(Integer, Integer)" $ + ioProperty . concreteSubstSymOkProp @(Integer, Integer), + testCase "(SymBool, SymBool)" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + substSym asym b (a, c) @?= (b, c) + ], + testGroup + "(,,)" + [ testProperty "(Integer, Integer, Integer)" $ + ioProperty + . concreteSubstSymOkProp @(Integer, Integer, Integer), + testCase "(SymBool, SymBool, SymBool)" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + substSym asym b (a, c, a) @?= (b, c, b) + ], + testGroup + "(,,,)" + [ testProperty "(Integer, Integer, Integer, Integer)" $ + ioProperty + . concreteSubstSymOkProp + @(Integer, Integer, Integer, Integer), + testCase "(SymBool, SymBool, SymBool, SymBool)" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + substSym asym b (a, c, a, c) @?= (b, c, b, c) + ], + testGroup + "(,,,,)" + [ testProperty "(Integer, Integer, Integer, Integer, Integer)" $ + ioProperty + . concreteSubstSymOkProp + @(Integer, Integer, Integer, Integer, Integer), + testCase "(SymBool, SymBool, SymBool, SymBool, SymBool)" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + substSym asym b (a, c, a, c, a) @?= (b, c, b, c, b) + ], + testGroup + "(,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteSubstSymOkProp + @(Integer, Integer, Integer, Integer, Integer, Integer), + testCase + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + substSym asym b (a, c, a, c, a, c) @?= (b, c, b, c, b, c) + ], + testGroup + "(,,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteSubstSymOkProp + @( Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer + ), + testCase + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + substSym asym b (a, c, a, c, a, c, a) + @?= (b, c, b, c, b, c, b) + ], + testGroup + "(,,,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteSubstSymOkProp + @( Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer + ), + testCase + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + substSym asym b (a, c, a, c, a, c, a, c) + @?= (b, c, b, c, b, c, b, c) + ], + testProperty "ByteString" $ + ioProperty + . concreteSubstSymOkProp @B.ByteString + . B.pack, + testGroup + "Sum" + [ testProperty + "Sum Maybe Maybe Integer" + ( ioProperty + . concreteSubstSymOkProp @(Sum Maybe Maybe Integer) + . ( \case + Left x -> InL x + Right x -> InL x + ) + ), + testCase + "Sum Maybe Maybe SymBool" + ( do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst :: + Sum Maybe Maybe SymBool -> + Sum Maybe Maybe SymBool + subst = substSym asym b + subst (InL Nothing) @?= InL Nothing + subst (InL (Just a)) @?= InL (Just b) + subst (InL (Just c)) @?= InL (Just c) + subst (InR Nothing) @?= InR Nothing + subst (InR (Just a)) @?= InR (Just b) + subst (InR (Just c)) @?= InR (Just c) + ) + ], + testGroup + "WriterT" + [ testGroup + "Lazy" + [ testProperty + "WriterT Integer (Either Integer) Integer" + ( ioProperty + . concreteSubstSymOkProp + @(WriterLazy.WriterT Integer (Either Integer) Integer) + . WriterLazy.WriterT + ), + testCase "WriterT SymBool (Either SymBool) SymBool" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool -> + WriterLazy.WriterT SymBool (Either SymBool) SymBool + subst = substSym asym b + subst + (WriterLazy.WriterT (Left a)) + @?= WriterLazy.WriterT (Left b) + subst + (WriterLazy.WriterT (Left c)) + @?= WriterLazy.WriterT (Left c) + subst + (WriterLazy.WriterT (Right (a, a))) + @?= WriterLazy.WriterT (Right (b, b)) + subst + (WriterLazy.WriterT (Right (c, c))) + @?= WriterLazy.WriterT (Right (c, c)) + ], + testGroup + "Strict" + [ testProperty + "WriterT Integer (Either Integer) Integer" + ( ioProperty + . concreteSubstSymOkProp + @( WriterStrict.WriterT + Integer + (Either Integer) + Integer + ) + . WriterStrict.WriterT + ), + testCase "WriterT SymBool (Either SymBool) SymBool" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst :: + WriterStrict.WriterT + SymBool + (Either SymBool) + SymBool -> + WriterStrict.WriterT + SymBool + (Either SymBool) + SymBool + subst = substSym asym b + subst + (WriterStrict.WriterT (Left a)) + @?= WriterStrict.WriterT (Left b) + subst + (WriterStrict.WriterT (Left c)) + @?= WriterStrict.WriterT (Left c) + subst + (WriterStrict.WriterT (Right (a, a))) + @?= WriterStrict.WriterT (Right (b, b)) + subst + (WriterStrict.WriterT (Right (c, c))) + @?= WriterStrict.WriterT (Right (c, c)) + ] + ], + testGroup + "Identity" + [ testProperty + "Identity Integer" + (ioProperty . concreteSubstSymOkProp @(Identity Integer)), + testCase "Identity SymBool" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst :: Identity SymBool -> Identity SymBool + subst = substSym asym b + subst (Identity a) @?= Identity b + subst (Identity c) @?= Identity c + ], + testGroup + "IdentityT" + [ testProperty + "IdentityT (Either Integer) Integer" + $ ioProperty + . concreteSubstSymOkProp + @(IdentityT (Either Integer) Integer) + . IdentityT, + testCase "IdentityT (Either SymBool) SymBool" $ do + let asym = ssymbolBool "a" + let a = ssymBool "a" + let b = ssymBool "b" + let c = ssymBool "c" + let subst :: + IdentityT (Either SymBool) SymBool -> + IdentityT (Either SymBool) SymBool + subst = substSym asym b + subst (IdentityT (Left a)) @?= IdentityT (Left b) + subst (IdentityT (Left c)) @?= IdentityT (Left c) + subst (IdentityT (Right a)) @?= IdentityT (Right b) + subst (IdentityT (Right c)) @?= IdentityT (Right c) + ] + ] + ] diff --git a/test/Grisette/Core/Data/Class/SubstituteSymTests.hs b/test/Grisette/Core/Data/Class/SubstituteSymTests.hs deleted file mode 100644 --- a/test/Grisette/Core/Data/Class/SubstituteSymTests.hs +++ /dev/null @@ -1,416 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Grisette.Core.Data.Class.SubstituteSymTests (substituteSymTests) where - -import Control.Monad.Except (ExceptT (ExceptT)) -import Control.Monad.Identity - ( Identity (Identity), - IdentityT (IdentityT), - ) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) -import qualified Control.Monad.Writer.Lazy as WriterLazy -import qualified Control.Monad.Writer.Strict as WriterStrict -import qualified Data.ByteString as B -import Data.Functor.Sum (Sum (InL, InR)) -import Data.Int (Int16, Int32, Int64, Int8) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.Stack (HasCallStack) -import Grisette (LogicalOp ((.||)), SubstituteSym (substituteSym), SymBool) -import Grisette.Core.Data.Class.TestValues (ssymBool, ssymbolBool) -import Test.Framework (Test, testGroup) -import Test.Framework.Providers.HUnit (testCase) -import Test.Framework.Providers.QuickCheck2 (testProperty) -import Test.HUnit (Assertion, (@?=)) -import Test.QuickCheck (ioProperty) - -concreteSubstituteSymOkProp :: - (HasCallStack, SubstituteSym a, Show a, Eq a) => a -> Assertion -concreteSubstituteSymOkProp x = - substituteSym (ssymbolBool "a") (ssymBool "b") x @?= x - -substituteSymTests :: Test -substituteSymTests = - testGroup - "SubstituteSym" - [ testGroup - "SubstituteSym for common types" - [ testCase "SymBool" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst = substituteSym asym b - subst a @?= b - subst c @?= c - subst (a .|| c) @?= b .|| c, - testProperty "Bool" $ ioProperty . concreteSubstituteSymOkProp @Bool, - testProperty "Integer" $ - ioProperty . concreteSubstituteSymOkProp @Integer, - testProperty "Char" $ ioProperty . concreteSubstituteSymOkProp @Char, - testProperty "Int" $ ioProperty . concreteSubstituteSymOkProp @Int, - testProperty "Int8" $ ioProperty . concreteSubstituteSymOkProp @Int8, - testProperty "Int16" $ - ioProperty . concreteSubstituteSymOkProp @Int16, - testProperty "Int32" $ - ioProperty . concreteSubstituteSymOkProp @Int32, - testProperty "Int64" $ - ioProperty . concreteSubstituteSymOkProp @Int64, - testProperty "Word" $ ioProperty . concreteSubstituteSymOkProp @Word, - testProperty "Word8" $ - ioProperty . concreteSubstituteSymOkProp @Word8, - testProperty "Word16" $ - ioProperty . concreteSubstituteSymOkProp @Word16, - testProperty "Word32" $ - ioProperty . concreteSubstituteSymOkProp @Word32, - testProperty "Word64" $ - ioProperty . concreteSubstituteSymOkProp @Word64, - testGroup - "List" - [ testProperty "[Integer]" $ - ioProperty . concreteSubstituteSymOkProp @[Integer], - testCase "[SymBool]" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst = substituteSym asym b - subst [a, c] @?= [b, c] - ], - testGroup - "Maybe" - [ testProperty "Maybe Integer" $ - ioProperty . concreteSubstituteSymOkProp @(Maybe Integer), - testCase "Maybe SymBool" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst :: Maybe SymBool -> Maybe SymBool - subst = substituteSym asym b - subst (Just a) @?= Just b - subst (Just c) @?= Just c - subst Nothing @?= Nothing - ], - testGroup - "Either" - [ testProperty "Either Integer Integer" $ - ioProperty - . concreteSubstituteSymOkProp @(Either Integer Integer), - testCase "Either SymBool SymBool" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst :: Either SymBool SymBool -> Either SymBool SymBool - subst = substituteSym asym b - subst (Left a) @?= Left b - subst (Left c) @?= Left c - subst (Right a) @?= Right b - subst (Right c) @?= Right c - ], - testGroup - "MaybeT" - [ testProperty "MaybeT Maybe Integer" $ - ioProperty - . concreteSubstituteSymOkProp @(MaybeT Maybe Integer) - . MaybeT, - testCase "MaybeT Maybe SymBool" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst :: MaybeT Maybe SymBool -> MaybeT Maybe SymBool - subst = substituteSym asym b - subst (MaybeT Nothing) @?= MaybeT Nothing - subst (MaybeT (Just Nothing)) @?= MaybeT (Just Nothing) - subst (MaybeT (Just (Just a))) @?= MaybeT (Just (Just b)) - subst (MaybeT (Just (Just c))) @?= MaybeT (Just (Just c)) - ], - testGroup - "ExceptT" - [ testProperty "ExceptT Maybe Integer" $ - ioProperty - . concreteSubstituteSymOkProp @(ExceptT Integer Maybe Integer) - . ExceptT, - testCase "ExceptT SymBool Maybe SymBool" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst :: - ExceptT SymBool Maybe SymBool -> - ExceptT SymBool Maybe SymBool - subst = substituteSym asym b - subst (ExceptT Nothing) @?= ExceptT Nothing - subst (ExceptT $ Just $ Left a) @?= ExceptT (Just $ Left b) - subst (ExceptT $ Just $ Left c) @?= ExceptT (Just $ Left c) - subst (ExceptT $ Just $ Right a) @?= ExceptT (Just $ Right b) - subst (ExceptT $ Just $ Right c) @?= ExceptT (Just $ Right c) - ], - testProperty "()" (ioProperty . concreteSubstituteSymOkProp @()), - testGroup - "(,)" - [ testProperty "(Integer, Integer)" $ - ioProperty . concreteSubstituteSymOkProp @(Integer, Integer), - testCase "(SymBool, SymBool)" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - substituteSym asym b (a, c) @?= (b, c) - ], - testGroup - "(,,)" - [ testProperty "(Integer, Integer, Integer)" $ - ioProperty - . concreteSubstituteSymOkProp @(Integer, Integer, Integer), - testCase "(SymBool, SymBool, SymBool)" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - substituteSym asym b (a, c, a) @?= (b, c, b) - ], - testGroup - "(,,,)" - [ testProperty "(Integer, Integer, Integer, Integer)" $ - ioProperty - . concreteSubstituteSymOkProp - @(Integer, Integer, Integer, Integer), - testCase "(SymBool, SymBool, SymBool, SymBool)" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - substituteSym asym b (a, c, a, c) @?= (b, c, b, c) - ], - testGroup - "(,,,,)" - [ testProperty "(Integer, Integer, Integer, Integer, Integer)" $ - ioProperty - . concreteSubstituteSymOkProp - @(Integer, Integer, Integer, Integer, Integer), - testCase "(SymBool, SymBool, SymBool, SymBool, SymBool)" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - substituteSym asym b (a, c, a, c, a) @?= (b, c, b, c, b) - ], - testGroup - "(,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteSubstituteSymOkProp - @(Integer, Integer, Integer, Integer, Integer, Integer), - testCase - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - substituteSym asym b (a, c, a, c, a, c) @?= (b, c, b, c, b, c) - ], - testGroup - "(,,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteSubstituteSymOkProp - @( Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer - ), - testCase - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - substituteSym asym b (a, c, a, c, a, c, a) - @?= (b, c, b, c, b, c, b) - ], - testGroup - "(,,,,,,,)" - [ testProperty - "(Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)" - $ ioProperty - . concreteSubstituteSymOkProp - @( Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer, - Integer - ), - testCase - "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" - $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - substituteSym asym b (a, c, a, c, a, c, a, c) - @?= (b, c, b, c, b, c, b, c) - ], - testProperty "ByteString" $ - ioProperty - . concreteSubstituteSymOkProp @B.ByteString - . B.pack, - testGroup - "Sum" - [ testProperty - "Sum Maybe Maybe Integer" - ( ioProperty - . concreteSubstituteSymOkProp @(Sum Maybe Maybe Integer) - . ( \case - Left x -> InL x - Right x -> InL x - ) - ), - testCase - "Sum Maybe Maybe SymBool" - ( do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst :: - Sum Maybe Maybe SymBool -> - Sum Maybe Maybe SymBool - subst = substituteSym asym b - subst (InL Nothing) @?= InL Nothing - subst (InL (Just a)) @?= InL (Just b) - subst (InL (Just c)) @?= InL (Just c) - subst (InR Nothing) @?= InR Nothing - subst (InR (Just a)) @?= InR (Just b) - subst (InR (Just c)) @?= InR (Just c) - ) - ], - testGroup - "WriterT" - [ testGroup - "Lazy" - [ testProperty - "WriterT Integer (Either Integer) Integer" - ( ioProperty - . concreteSubstituteSymOkProp - @(WriterLazy.WriterT Integer (Either Integer) Integer) - . WriterLazy.WriterT - ), - testCase "WriterT SymBool (Either SymBool) SymBool" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst :: - WriterLazy.WriterT SymBool (Either SymBool) SymBool -> - WriterLazy.WriterT SymBool (Either SymBool) SymBool - subst = substituteSym asym b - subst - (WriterLazy.WriterT (Left a)) - @?= WriterLazy.WriterT (Left b) - subst - (WriterLazy.WriterT (Left c)) - @?= WriterLazy.WriterT (Left c) - subst - (WriterLazy.WriterT (Right (a, a))) - @?= WriterLazy.WriterT (Right (b, b)) - subst - (WriterLazy.WriterT (Right (c, c))) - @?= WriterLazy.WriterT (Right (c, c)) - ], - testGroup - "Strict" - [ testProperty - "WriterT Integer (Either Integer) Integer" - ( ioProperty - . concreteSubstituteSymOkProp - @( WriterStrict.WriterT - Integer - (Either Integer) - Integer - ) - . WriterStrict.WriterT - ), - testCase "WriterT SymBool (Either SymBool) SymBool" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst :: - WriterStrict.WriterT - SymBool - (Either SymBool) - SymBool -> - WriterStrict.WriterT - SymBool - (Either SymBool) - SymBool - subst = substituteSym asym b - subst - (WriterStrict.WriterT (Left a)) - @?= WriterStrict.WriterT (Left b) - subst - (WriterStrict.WriterT (Left c)) - @?= WriterStrict.WriterT (Left c) - subst - (WriterStrict.WriterT (Right (a, a))) - @?= WriterStrict.WriterT (Right (b, b)) - subst - (WriterStrict.WriterT (Right (c, c))) - @?= WriterStrict.WriterT (Right (c, c)) - ] - ], - testGroup - "Identity" - [ testProperty - "Identity Integer" - (ioProperty . concreteSubstituteSymOkProp @(Identity Integer)), - testCase "Identity SymBool" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst :: Identity SymBool -> Identity SymBool - subst = substituteSym asym b - subst (Identity a) @?= Identity b - subst (Identity c) @?= Identity c - ], - testGroup - "IdentityT" - [ testProperty - "IdentityT (Either Integer) Integer" - $ ioProperty - . concreteSubstituteSymOkProp - @(IdentityT (Either Integer) Integer) - . IdentityT, - testCase "IdentityT (Either SymBool) SymBool" $ do - let asym = ssymbolBool "a" - let a = ssymBool "a" - let b = ssymBool "b" - let c = ssymBool "c" - let subst :: - IdentityT (Either SymBool) SymBool -> - IdentityT (Either SymBool) SymBool - subst = substituteSym asym b - subst (IdentityT (Left a)) @?= IdentityT (Left b) - subst (IdentityT (Left c)) @?= IdentityT (Left c) - subst (IdentityT (Right a)) @?= IdentityT (Right b) - subst (IdentityT (Right c)) @?= IdentityT (Right c) - ] - ] - ] diff --git a/test/Grisette/Core/Data/Class/SymEqTests.hs b/test/Grisette/Core/Data/Class/SymEqTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/SymEqTests.hs @@ -0,0 +1,720 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Core.Data.Class.SymEqTests (seqTests) where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Data.Bifunctor (Bifunctor (bimap)) +import qualified Data.ByteString as B +import Data.Foldable (traverse_) +import Data.Functor.Sum (Sum (InL, InR)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Stack (HasCallStack) +import Generics.Deriving (Default (Default), Generic) +import Grisette + ( LogicalOp (symNot, (.&&)), + Solvable (con), + SymBool (SymBool), + SymEq ((./=), (.==)), + ) +import Grisette.Core.Data.Class.TestValues + ( conBool, + ssymBool, + ) +import Grisette.Internal.SymPrim.Prim.Term (pevalEqTerm) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, (@=?)) +import Test.QuickCheck (ioProperty) + +data A = A1 | A2 SymBool | A3 SymBool SymBool + deriving (Generic, Show, Eq) + deriving (SymEq) via (Default A) + +concreteSymEqOkProp :: (HasCallStack, SymEq a, Eq a) => (a, a) -> Assertion +concreteSymEqOkProp (i, j) = do + i .== j @=? con (i == j) + i ./= j @=? con (i /= j) + +seqTests :: Test +seqTests = + testGroup + "SymEq" + [ testGroup + "SymEq for common types" + [ testGroup + "SymBool" + [ testCase "conBool" $ do + let bools :: [Bool] = [True, False] + traverse_ + ( \(i, j) -> + conBool i + .== conBool j + @=? conBool (i == j) + ) + [(x, y) | x <- bools, y <- bools], + testCase "conBool True vs SymBool" $ do + conBool True .== ssymBool "a" @=? ssymBool "a", + testCase "conBool False vs SymBool" $ do + conBool False .== ssymBool "a" @=? symNot (ssymBool "a"), + testCase "SymBool vs conBool True" $ do + ssymBool "a" .== conBool True @=? ssymBool "a", + testCase "SymBool vs conBool False" $ do + ssymBool "a" .== conBool False @=? symNot (ssymBool "a"), + testCase "SymBool vs same SymBool" $ do + ssymBool "a" .== ssymBool "a" @=? conBool True, + testCase "SymBool vs different SymBool" $ do + let SymBool terma = ssymBool "a" + SymBool termb = ssymBool "b" + ssymBool "a" + .== ssymBool "b" + @=? SymBool (pevalEqTerm terma termb) + ], + testProperty "Bool" (ioProperty . concreteSymEqOkProp @Bool), + testProperty "Integer" (ioProperty . concreteSymEqOkProp @Integer), + testProperty "Char" (ioProperty . concreteSymEqOkProp @Char), + testProperty "Int" (ioProperty . concreteSymEqOkProp @Int), + testProperty "Int8" (ioProperty . concreteSymEqOkProp @Int8), + testProperty "Int16" (ioProperty . concreteSymEqOkProp @Int16), + testProperty "Int32" (ioProperty . concreteSymEqOkProp @Int32), + testProperty "Int64" (ioProperty . concreteSymEqOkProp @Int64), + testProperty "Word" (ioProperty . concreteSymEqOkProp @Word), + testProperty "Word8" (ioProperty . concreteSymEqOkProp @Word8), + testProperty "Word16" (ioProperty . concreteSymEqOkProp @Word16), + testProperty "Word32" (ioProperty . concreteSymEqOkProp @Word32), + testProperty "Word64" (ioProperty . concreteSymEqOkProp @Word64), + testGroup + "List" + [ testProperty "[Integer]" $ + ioProperty . concreteSymEqOkProp @[Integer], + testGroup + "[SymBool]" + [ testCase "Same length 1" $ + [ssymBool "a"] + .== [ssymBool "b"] + @=? ssymBool "a" + .== ssymBool "b", + testCase "Same length 2" $ + [ssymBool "a", ssymBool "b"] + .== [ssymBool "c", ssymBool "d"] + @=? (ssymBool "a" .== ssymBool "c") + .&& (ssymBool "b" .== ssymBool "d"), + testCase "length 1 vs length 0" $ + [ssymBool "a"] .== [] @=? conBool False, + testCase "length 1 vs length 2" $ + [ssymBool "a"] + .== [ssymBool "c", ssymBool "d"] + @=? conBool False + ] + ], + testGroup + "Maybe" + [ testProperty "Maybe Integer" $ + ioProperty . concreteSymEqOkProp @(Maybe Integer), + testGroup + "Maybe SymBool" + [ testCase "Nothing vs Nothing" $ + (Nothing :: Maybe SymBool) .== Nothing @=? conBool True, + testCase "Just vs Nothing" $ + Just (ssymBool "a") .== Nothing @=? conBool False, + testCase "Nothing vs Just" $ + Nothing .== Just (ssymBool "a") @=? conBool False, + testCase "Just vs Just" $ + Just (ssymBool "a") + .== Just (ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b" + ] + ], + testGroup + "Either" + [ testProperty "Either" $ + ioProperty . concreteSymEqOkProp @(Either Integer Integer), + testGroup + "Either SymBool SymBool" + [ testCase "Left vs Left" $ + (Left (ssymBool "a") :: Either SymBool SymBool) + .== Left (ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b", + testCase "Right vs Left" $ + (Right (ssymBool "a") :: Either SymBool SymBool) + .== Left (ssymBool "b") + @=? conBool False, + testCase "Left vs Right" $ + (Left (ssymBool "a") :: Either SymBool SymBool) + .== Right (ssymBool "b") + @=? conBool False, + testCase "Right vs Right" $ + (Right (ssymBool "a") :: Either SymBool SymBool) + .== Right (ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b" + ] + ], + testGroup + "MaybeT" + [ testProperty "MaybeT" $ + ioProperty + . concreteSymEqOkProp @(MaybeT Maybe Integer) + . bimap MaybeT MaybeT, + testGroup + "MaybeT Maybe SymBool" + [ testCase "MaybeT Nothing vs MaybeT Nothing" $ + (MaybeT Nothing :: MaybeT Maybe SymBool) + .== MaybeT Nothing + @=? conBool True, + testCase "MaybeT Nothing vs MaybeT (Just Nothing)" $ + (MaybeT Nothing :: MaybeT Maybe SymBool) + .== MaybeT (Just Nothing) + @=? conBool False, + testCase "MaybeT Nothing vs MaybeT (Just (Just v))" $ + (MaybeT Nothing :: MaybeT Maybe SymBool) + .== MaybeT (Just (Just (ssymBool "a"))) + @=? conBool False, + testCase "MaybeT (Just Nothing) vs MaybeT Nothing" $ + MaybeT (Just Nothing) + .== (MaybeT Nothing :: MaybeT Maybe SymBool) + @=? conBool False, + testCase "MaybeT (Just (Just v)) vs MaybeT Nothing" $ + MaybeT (Just (Just (ssymBool "a"))) + .== (MaybeT Nothing :: MaybeT Maybe SymBool) + @=? conBool False, + testCase "MaybeT (Just Nothing) vs MaybeT (Just Nothing)" $ + MaybeT (Just Nothing) + .== (MaybeT (Just Nothing) :: MaybeT Maybe SymBool) + @=? conBool True, + testCase "MaybeT (Just (Just v)) vs MaybeT (Just Nothing)" $ + MaybeT (Just (Just (ssymBool "a"))) + .== (MaybeT (Just Nothing) :: MaybeT Maybe SymBool) + @=? conBool False, + testCase "MaybeT (Just Nothing) vs MaybeT (Just (Just v))" $ + MaybeT (Just Nothing) + .== ( MaybeT (Just (Just (ssymBool "b"))) :: + MaybeT Maybe SymBool + ) + @=? conBool False, + testCase "MaybeT (Just (Just v)) vs MaybeT (Just (Just v))" $ + MaybeT (Just (Just (ssymBool "a"))) + .== ( MaybeT (Just (Just (ssymBool "b"))) :: + MaybeT Maybe SymBool + ) + @=? ssymBool "a" + .== ssymBool "b" + ] + ], + testGroup + "ExceptT" + [ testProperty "ExceptT Integer Maybe Itneger" $ + ioProperty + . concreteSymEqOkProp @(ExceptT Integer Maybe Integer) + . bimap ExceptT ExceptT, + testGroup + "ExceptT SymBool Maybe SymBool" + [ testCase "ExceptT Nothing vs ExceptT Nothing" $ + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .== ExceptT Nothing + @=? conBool True, + testCase "ExceptT Nothing vs ExceptT (Just (Left v))" $ + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .== ExceptT (Just (Left (ssymBool "a"))) + @=? conBool False, + testCase "ExceptT Nothing vs ExceptT (Just (Right v))" $ + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .== ExceptT (Just (Right (ssymBool "a"))) + @=? conBool False, + testCase "ExceptT (Just (Left v)) vs ExceptT Nothing" $ + ExceptT (Just (Left (ssymBool "a"))) + .== (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + @=? conBool False, + testCase "ExceptT (Just (Right v)) vs ExceptT Nothing" $ + ExceptT (Just (Right (ssymBool "a"))) + .== (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + @=? conBool False, + testCase + "ExceptT (Just (Left v)) vs ExceptT (Just (Left v))" + $ ExceptT (Just (Left (ssymBool "a"))) + .== ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + @=? ssymBool "a" + .== ssymBool "b", + testCase + "ExceptT (Just (Right v)) vs ExceptT (Just (Left v))" + $ ExceptT (Just (Right (ssymBool "a"))) + .== ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + @=? conBool False, + testCase + "ExceptT (Just (Left v)) vs ExceptT (Just (Right v))" + $ ExceptT (Just (Left (ssymBool "a"))) + .== ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + @=? conBool False, + testCase + "ExceptT (Just (Right v)) vs ExceptT (Just (Right v))" + $ ExceptT (Just (Right (ssymBool "a"))) + .== ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + @=? ssymBool "a" + .== ssymBool "b" + ] + ], + testProperty "()" (ioProperty . concreteSymEqOkProp @()), + testGroup + "(,)" + [ testProperty "(Integer, Integer)" $ + ioProperty . concreteSymEqOkProp @(Integer, Integer), + testCase "(SymBool, SymBool)" $ do + (ssymBool "a", ssymBool "c") + .== (ssymBool "b", ssymBool "d") + @=? ssymBool "a" + .== ssymBool "b" + .&& ssymBool "c" + .== ssymBool "d" + ], + testGroup + "(,,)" + [ testProperty "(Integer, Integer, Integer)" $ + ioProperty . concreteSymEqOkProp @(Integer, Integer, Integer), + testCase "(SymBool, SymBool, SymBool)" $ + (ssymBool "a", ssymBool "c", ssymBool "e") + .== (ssymBool "b", ssymBool "d", ssymBool "f") + @=? (ssymBool "a" .== ssymBool "b") + .&& ( (ssymBool "c" .== ssymBool "d") + .&& (ssymBool "e" .== ssymBool "f") + ) + ], + testGroup + "(,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteSymEqOkProp @(Integer, Integer, Integer, Integer), + testCase "(SymBool, SymBool, SymBool, SymBool)" $ do + (ssymBool "a", ssymBool "c", ssymBool "e", ssymBool "g") + .== (ssymBool "b", ssymBool "d", ssymBool "f", ssymBool "h") + @=? ( (ssymBool "a" .== ssymBool "b") + .&& (ssymBool "c" .== ssymBool "d") + ) + .&& ( (ssymBool "e" .== ssymBool "f") + .&& (ssymBool "g" .== ssymBool "h") + ) + ], + testGroup + "(,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteSymEqOkProp + @(Integer, Integer, Integer, Integer, Integer), + testCase "(SymBool, SymBool, SymBool, SymBool, SymBool)" $ do + ( ssymBool "a", + ssymBool "c", + ssymBool "e", + ssymBool "g", + ssymBool "i" + ) + .== ( ssymBool "b", + ssymBool "d", + ssymBool "f", + ssymBool "h", + ssymBool "j" + ) + @=? ( (ssymBool "a" .== ssymBool "b") + .&& (ssymBool "c" .== ssymBool "d") + ) + .&& ( (ssymBool "e" .== ssymBool "f") + .&& ( (ssymBool "g" .== ssymBool "h") + .&& (ssymBool "i" .== ssymBool "j") + ) + ) + ], + testGroup + "(,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteSymEqOkProp + @( Integer, + Integer, + Integer, + Integer, + Integer, + Integer + ), + testCase + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + $ ( ssymBool "a", + ssymBool "c", + ssymBool "e", + ssymBool "g", + ssymBool "i", + ssymBool "k" + ) + .== ( ssymBool "b", + ssymBool "d", + ssymBool "f", + ssymBool "h", + ssymBool "j", + ssymBool "l" + ) + @=? ( (ssymBool "a" .== ssymBool "b") + .&& ( (ssymBool "c" .== ssymBool "d") + .&& (ssymBool "e" .== ssymBool "f") + ) + ) + .&& ( (ssymBool "g" .== ssymBool "h") + .&& ( (ssymBool "i" .== ssymBool "j") + .&& (ssymBool "k" .== ssymBool "l") + ) + ) + ], + testGroup + "(,,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteSymEqOkProp + @( Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer + ), + testCase + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + $ do + ( ssymBool "a", + ssymBool "c", + ssymBool "e", + ssymBool "g", + ssymBool "i", + ssymBool "k", + ssymBool "m" + ) + .== ( ssymBool "b", + ssymBool "d", + ssymBool "f", + ssymBool "h", + ssymBool "j", + ssymBool "l", + ssymBool "n" + ) + @=? ( (ssymBool "a" .== ssymBool "b") + .&& ( (ssymBool "c" .== ssymBool "d") + .&& (ssymBool "e" .== ssymBool "f") + ) + ) + .&& ( ( (ssymBool "g" .== ssymBool "h") + .&& (ssymBool "i" .== ssymBool "j") + ) + .&& ( (ssymBool "k" .== ssymBool "l") + .&& (ssymBool "m" .== ssymBool "n") + ) + ) + ], + testGroup + "(,,,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteSymEqOkProp + @( Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer + ), + testCase + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + $ ( ssymBool "a", + ssymBool "c", + ssymBool "e", + ssymBool "g", + ssymBool "i", + ssymBool "k", + ssymBool "m", + ssymBool "o" + ) + .== ( ssymBool "b", + ssymBool "d", + ssymBool "f", + ssymBool "h", + ssymBool "j", + ssymBool "l", + ssymBool "n", + ssymBool "p" + ) + @=? ( ( (ssymBool "a" .== ssymBool "b") + .&& (ssymBool "c" .== ssymBool "d") + ) + .&& ( (ssymBool "e" .== ssymBool "f") + .&& (ssymBool "g" .== ssymBool "h") + ) + ) + .&& ( ( (ssymBool "i" .== ssymBool "j") + .&& (ssymBool "k" .== ssymBool "l") + ) + .&& ( (ssymBool "m" .== ssymBool "n") + .&& (ssymBool "o" .== ssymBool "p") + ) + ) + ], + testCase "ByteString" $ do + let bytestrings :: [B.ByteString] = ["", "a", "ab"] + traverse_ + (\(i, j) -> i .== j @=? conBool (i == j)) + [(x, y) | x <- bytestrings, y <- bytestrings], + testGroup + "Sum" + [ testProperty "Sum Maybe Maybe Integer" $ + ioProperty + . ( \v -> + let eitherToSum :: + Either (Maybe Integer) (Maybe Integer) -> + Sum Maybe Maybe Integer + eitherToSum (Left x) = InL x + eitherToSum (Right x) = InR x + in concreteSymEqOkProp (bimap eitherToSum eitherToSum v) + ), + testGroup + "Sum Maybe Maybe SymBool" + [ testCase "InL (Just v) vs InL (Just v)" $ + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .== InL (Just $ ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b", + testCase "InL (Just v) vs InR (Just v)" $ + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .== InR (Just $ ssymBool "b") + @=? conBool False, + testCase "InR (Just v) vs InR (Just v)" $ + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .== InR (Just $ ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b", + testCase "InR (Just v) vs InL (Just v)" $ + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .== InL (Just $ ssymBool "b") + @=? conBool False + ] + ], + testGroup + "Writer" + [ testGroup + "Lazy" + [ testProperty + "WriterT Integer (Either Integer) Integer" + ( ioProperty + . \( v1 :: Either Integer (Integer, Integer), + v2 :: Either Integer (Integer, Integer) + ) -> + concreteSymEqOkProp + ( WriterLazy.WriterT v1, + WriterLazy.WriterT v2 + ) + ), + testGroup + "WriterT SymBool (Either SymBool) SymBool" + [ testCase "WriterT (Left v) vs WriterT (Left v)" $ + ( WriterLazy.WriterT (Left $ ssymBool "a") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .== WriterLazy.WriterT (Left $ ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b", + testCase "WriterT (Left v) vs WriterT (Right v)" $ + ( WriterLazy.WriterT (Left $ ssymBool "a") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .== WriterLazy.WriterT + (Right (ssymBool "b", ssymBool "c")) + @=? conBool False, + testCase "WriterT (Right v) vs WriterT (Left v)" $ + ( WriterLazy.WriterT + (Right (ssymBool "b", ssymBool "c")) :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .== WriterLazy.WriterT (Left $ ssymBool "a") + @=? conBool False, + testCase "WriterT (Right v) vs WriterT (Right v)" $ + ( WriterLazy.WriterT + (Right (ssymBool "a", ssymBool "b")) :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .== WriterLazy.WriterT + (Right (ssymBool "c", ssymBool "d")) + @=? (ssymBool "a" .== ssymBool "c") + .&& (ssymBool "b" .== ssymBool "d") + ] + ], + testGroup + "Strict" + [ testProperty + "WriterT Integer (Either Integer) Integer" + ( ioProperty + . \( v1 :: Either Integer (Integer, Integer), + v2 :: Either Integer (Integer, Integer) + ) -> + concreteSymEqOkProp + ( WriterStrict.WriterT v1, + WriterStrict.WriterT v2 + ) + ), + testGroup + "WriterT SymBool (Either SymBool) SymBool" + [ testCase "WriterT (Left v) vs WriterT (Left v)" $ + ( WriterStrict.WriterT (Left $ ssymBool "a") :: + WriterStrict.WriterT + SymBool + (Either SymBool) + SymBool + ) + .== WriterStrict.WriterT (Left $ ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b", + testCase "WriterT (Left v) vs WriterT (Right v)" $ + ( WriterStrict.WriterT (Left $ ssymBool "a") :: + WriterStrict.WriterT + SymBool + (Either SymBool) + SymBool + ) + .== WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "c")) + @=? conBool False, + testCase "WriterT (Right v) vs WriterT (Left v)" $ + ( WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "c")) :: + WriterStrict.WriterT + SymBool + (Either SymBool) + SymBool + ) + .== WriterStrict.WriterT (Left $ ssymBool "a") + @=? conBool False, + testCase "WriterT (Right v) vs WriterT (Right v)" $ + ( WriterStrict.WriterT + (Right (ssymBool "a", ssymBool "b")) :: + WriterStrict.WriterT + SymBool + (Either SymBool) + SymBool + ) + .== WriterStrict.WriterT + (Right (ssymBool "c", ssymBool "d")) + @=? ssymBool "a" + .== ssymBool "c" + .&& ssymBool "b" + .== ssymBool "d" + ] + ] + ], + testGroup + "Identity" + [ testProperty + "Identity Integer" + ( ioProperty . \(v1 :: Integer, v2) -> + concreteSymEqOkProp (Identity v1, Identity v2) + ), + testCase "Identity SymBool" $ do + (Identity $ ssymBool "a" :: Identity SymBool) + .== Identity (ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b" + ], + testGroup + "IdentityT" + [ testProperty + "IdentityT (Either Integer) Integer" + ( ioProperty . \(v1 :: Either Integer Integer, v2) -> + concreteSymEqOkProp (IdentityT v1, IdentityT v2) + ), + testGroup + "IdentityT (Either SymBool) SymBool" + [ testCase "IdentityT (Left v) vs IdentityT (Left v)" $ + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .== IdentityT (Left $ ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b", + testCase "IdentityT (Left v) vs IdentityT (Right v)" $ + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .== IdentityT (Right $ ssymBool "b") + @=? conBool False, + testCase "IdentityT (Right v) vs IdentityT (Left v)" $ + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .== IdentityT (Left $ ssymBool "b") + @=? conBool False, + testCase "IdentityT (Right v) vs IdentityT (Right v)" $ + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .== IdentityT (Right $ ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b" + ] + ] + ], + testGroup + "deriving SymEq for ADT" + [ testGroup + "Simple ADT" + [ testCase "A1 vs A1" $ + A1 .== A1 @=? conBool True, + testCase "A1 vs A2" $ + A1 .== A2 (ssymBool "a") @=? conBool False, + testCase "A1 vs A3" $ + A1 .== A3 (ssymBool "a") (ssymBool "b") @=? conBool False, + testCase "A2 vs A1" $ + A2 (ssymBool "a") .== A1 @=? conBool False, + testCase "A2 vs A2" $ + A2 (ssymBool "a") + .== A2 (ssymBool "b") + @=? ssymBool "a" + .== ssymBool "b", + testCase "A2 vs A3" $ + A2 (ssymBool "a") + .== A3 (ssymBool "b") (ssymBool "c") + @=? conBool False, + testCase "A3 vs A1" $ + A3 (ssymBool "a") (ssymBool "b") .== A1 @=? conBool False, + testCase "A3 vs A2" $ + A3 (ssymBool "a") (ssymBool "b") + .== A2 (ssymBool "c") + @=? conBool False, + testCase "A3 vs A3" $ + A3 (ssymBool "a") (ssymBool "b") + .== A3 (ssymBool "c") (ssymBool "d") + @=? (ssymBool "a" .== ssymBool "c") + .&& (ssymBool "b" .== ssymBool "d") + ] + ] + ] diff --git a/test/Grisette/Core/Data/Class/SymOrdTests.hs b/test/Grisette/Core/Data/Class/SymOrdTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/Class/SymOrdTests.hs @@ -0,0 +1,1408 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Grisette.Core.Data.Class.SymOrdTests (sordTests) where + +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity + ( Identity (Identity), + IdentityT (IdentityT), + ) +import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) +import qualified Control.Monad.Writer.Lazy as WriterLazy +import qualified Control.Monad.Writer.Strict as WriterStrict +import Data.Bifunctor (Bifunctor (bimap)) +import qualified Data.ByteString as B +import Data.Foldable (traverse_) +import Data.Functor.Sum (Sum (InL, InR)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Stack (HasCallStack) +import Grisette + ( ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + SymEq ((.==)), + SymOrd (symCompare, (.<), (.<=), (.>), (.>=)), + Union, + mrgIf, + mrgMax, + mrgMin, + mrgSingle, + symMax, + symMin, + ) +import Grisette.Core.Data.Class.TestValues + ( conBool, + ssymBool, + ) +import Grisette.Lib.Control.Monad (mrgReturn) +import Grisette.SymPrim (SymBool, SymInteger) +import Grisette.TestUtil.SymbolicAssertion ((.@?=)) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.HUnit (Assertion, (@?=)) +import Test.QuickCheck (ioProperty) + +concreteOrdOkProp :: (HasCallStack, SymOrd a, Ord a) => (a, a) -> Assertion +concreteOrdOkProp (i, j) = do + i .<= j @?= conBool (i <= j) + i .< j @?= conBool (i < j) + i .>= j @?= conBool (i >= j) + i .> j @?= conBool (i > j) + symCompare i j @?= (mrgReturn $ compare i j :: Union Ordering) + +symbolicProdOrdOkProp :: + (HasCallStack, Show v, Show vl, Show vr, SymOrd v, SymOrd vl, SymOrd vr) => + v -> + v -> + vl -> + vr -> + vl -> + vr -> + Assertion +symbolicProdOrdOkProp l r ll lr rl rr = do + l .<= r .@?= ((ll .< rl) .|| ((ll .== rl) .&& (lr .<= rr))) + l .< r .@?= ((ll .< rl) .|| ((ll .== rl) .&& (lr .< rr))) + l .>= r .@?= ((ll .> rl) .|| ((ll .== rl) .&& (lr .>= rr))) + l .> r .@?= ((ll .> rl) .|| ((ll .== rl) .&& (lr .> rr))) + l + `symCompare` r + @?= ( ( do + lc <- symCompare ll rl + case lc of + EQ -> symCompare lr rr + _ -> mrgReturn lc + ) :: + Union Ordering + ) + +sordTests :: Test +sordTests = + testGroup + "SymOrd" + [ testGroup + "SymOrd for common types" + [ testGroup + "SymBool" + [ testCase "Concrete SymBool" $ do + conBool False .<= conBool False @?= conBool True + conBool False .< conBool False @?= conBool False + conBool False .>= conBool False @?= conBool True + conBool False .> conBool False @?= conBool False + conBool False .<= conBool True @?= conBool True + conBool False .< conBool True @?= conBool True + conBool False .>= conBool True @?= conBool False + conBool False .> conBool True @?= conBool False + conBool True .<= conBool False @?= conBool False + conBool True .< conBool False @?= conBool False + conBool True .>= conBool False @?= conBool True + conBool True .> conBool False @?= conBool True + conBool True .<= conBool True @?= conBool True + conBool True .< conBool True @?= conBool False + conBool True .>= conBool True @?= conBool True + conBool True .> conBool True @?= conBool False, + testCase "Symbolic SymBool" $ do + ssymBool "a" + .<= ssymBool "b" + @?= (symNot (ssymBool "a")) + .|| (ssymBool "b") + ssymBool "a" + .< ssymBool "b" + @?= (symNot (ssymBool "a")) + .&& (ssymBool "b") + ssymBool "a" + .>= ssymBool "b" + @?= (ssymBool "a") + .|| (symNot (ssymBool "b")) + ssymBool "a" + .> ssymBool "b" + @?= (ssymBool "a") + .&& (symNot (ssymBool "b")) + symCompare (ssymBool "a") (ssymBool "b") + @?= ( mrgIf + ((symNot (ssymBool "a")) .&& (ssymBool "b")) + (mrgSingle LT) + ( mrgIf + ((ssymBool "a") .== (ssymBool "b")) + (mrgSingle EQ) + (mrgSingle GT) + ) :: + Union Ordering + ) + ], + testProperty "Bool" (ioProperty . concreteOrdOkProp @Bool), + testProperty "Integer" (ioProperty . concreteOrdOkProp @Integer), + testProperty "Char" (ioProperty . concreteOrdOkProp @Char), + testProperty "Int" (ioProperty . concreteOrdOkProp @Int), + testProperty "Int8" (ioProperty . concreteOrdOkProp @Int8), + testProperty "Int16" (ioProperty . concreteOrdOkProp @Int16), + testProperty "Int32" (ioProperty . concreteOrdOkProp @Int32), + testProperty "Int64" (ioProperty . concreteOrdOkProp @Int64), + testProperty "Word" (ioProperty . concreteOrdOkProp @Word), + testProperty "Word8" (ioProperty . concreteOrdOkProp @Word8), + testProperty "Word16" (ioProperty . concreteOrdOkProp @Word16), + testProperty "Word32" (ioProperty . concreteOrdOkProp @Word32), + testProperty "Word64" (ioProperty . concreteOrdOkProp @Word64), + testGroup + "List" + [ testProperty "[Integer]" $ + ioProperty . concreteOrdOkProp @[Integer], + testProperty "[String]" $ + ioProperty . concreteOrdOkProp @[String], + testCase "[SymBool]" $ do + ([] :: [SymBool]) .<= [] @?= conBool True + ([] :: [SymBool]) .< [] @?= conBool False + ([] :: [SymBool]) .>= [] @?= conBool True + ([] :: [SymBool]) .> [] @?= conBool False + ([] :: [SymBool]) + `symCompare` [] + @?= (mrgSingle EQ :: Union Ordering) + [] .<= [ssymBool "a"] @?= conBool True + [] .< [ssymBool "a"] @?= conBool True + [] .>= [ssymBool "a"] @?= conBool False + [] .> [ssymBool "a"] @?= conBool False + [] + `symCompare` [ssymBool "a"] + @?= (mrgSingle LT :: Union Ordering) + [ssymBool "a"] .<= [] @?= conBool False + [ssymBool "a"] .< [] @?= conBool False + [ssymBool "a"] .>= [] @?= conBool True + [ssymBool "a"] .> [] @?= conBool True + [ssymBool "a"] + `symCompare` [] + @?= (mrgSingle GT :: Union Ordering) + + [ssymBool "a", ssymBool "b"] + .<= [ssymBool "c"] + @?= (ssymBool "a" .< ssymBool "c" :: SymBool) + [ssymBool "a", ssymBool "b"] + .< [ssymBool "c"] + @?= (ssymBool "a" .< ssymBool "c" :: SymBool) + [ssymBool "a", ssymBool "b"] + .>= [ssymBool "c"] + @?= ( (ssymBool "a" .> ssymBool "c") + .|| (ssymBool "a" .== ssymBool "c") :: + SymBool + ) + [ssymBool "a", ssymBool "b"] + .> [ssymBool "c"] + @?= ( (ssymBool "a" .> ssymBool "c") + .|| (ssymBool "a" .== ssymBool "c") :: + SymBool + ) + [ssymBool "a"] + `symCompare` [ssymBool "b"] + @?= (ssymBool "a" `symCompare` ssymBool "b" :: Union Ordering) + + [ssymBool "a"] + .<= [ssymBool "b", ssymBool "c"] + @?= ( (ssymBool "a" .< ssymBool "b") + .|| (ssymBool "a" .== ssymBool "b") :: + SymBool + ) + [ssymBool "a"] + .< [ssymBool "b", ssymBool "c"] + @?= ( (ssymBool "a" .< ssymBool "b") + .|| (ssymBool "a" .== ssymBool "b") :: + SymBool + ) + [ssymBool "a"] + .>= [ssymBool "b", ssymBool "c"] + @?= (ssymBool "a" .> ssymBool "b" :: SymBool) + [ssymBool "a"] + .> [ssymBool "b", ssymBool "c"] + @?= (ssymBool "a" .> ssymBool "b" :: SymBool) + [ssymBool "a"] + `symCompare` [ssymBool "b", ssymBool "c"] + @?= ( mrgIf + (ssymBool "a" .< ssymBool "b") + (mrgSingle LT) + ( mrgIf + (ssymBool "a" .== ssymBool "b") + (mrgSingle LT) + (mrgSingle GT) + ) :: + Union Ordering + ) + + [ssymBool "a", ssymBool "b"] + .<= [ssymBool "c", ssymBool "d"] + @?= ( (ssymBool "a" .< ssymBool "c") + .|| ( ssymBool "a" + .== ssymBool "c" + .&& ( (ssymBool "b" .< ssymBool "d") + .|| (ssymBool "b" .== ssymBool "d") + ) + ) :: + SymBool + ) + [ssymBool "a", ssymBool "b"] + .< [ssymBool "c", ssymBool "d"] + @?= ( (ssymBool "a" .< ssymBool "c") + .|| ( ssymBool "a" + .== ssymBool "c" + .&& (ssymBool "b" .< ssymBool "d") + ) :: + SymBool + ) + [ssymBool "a", ssymBool "b"] + .>= [ssymBool "c", ssymBool "d"] + @?= ( (ssymBool "a" .> ssymBool "c") + .|| ( ssymBool "a" + .== ssymBool "c" + .&& ( (ssymBool "b" .> ssymBool "d") + .|| (ssymBool "b" .== ssymBool "d") + ) + ) :: + SymBool + ) + [ssymBool "a", ssymBool "b"] + .> [ssymBool "c", ssymBool "d"] + @?= ( (ssymBool "a" .> ssymBool "c") + .|| ( ssymBool "a" + .== ssymBool "c" + .&& (ssymBool "b" .> ssymBool "d") + ) :: + SymBool + ) + [ssymBool "a", ssymBool "b"] + `symCompare` [ssymBool "c", ssymBool "d"] + @?= ( mrgIf + (ssymBool "a" .< ssymBool "c") + (mrgSingle LT) + ( mrgIf + (ssymBool "a" .== ssymBool "c") + (ssymBool "b" `symCompare` ssymBool "d") + (mrgSingle GT) + ) :: + Union Ordering + ) + ], + testGroup + "Maybe" + [ testProperty "Maybe Integer" $ + ioProperty . concreteOrdOkProp @(Maybe Integer), + testCase "Maybe SymBool" $ do + (Nothing :: Maybe SymBool) .<= Nothing .@?= conBool True + (Nothing :: Maybe SymBool) .< Nothing .@?= conBool False + (Nothing :: Maybe SymBool) .>= Nothing .@?= conBool True + (Nothing :: Maybe SymBool) .> Nothing .@?= conBool False + (Nothing :: Maybe SymBool) + `symCompare` Nothing + @?= (mrgSingle EQ :: Union Ordering) + Nothing .<= Just (ssymBool "a") .@?= conBool True + Nothing .< Just (ssymBool "a") .@?= conBool True + Nothing .>= Just (ssymBool "a") .@?= conBool False + Nothing .> Just (ssymBool "a") .@?= conBool False + Nothing + `symCompare` Just (ssymBool "a") + @?= (mrgSingle LT :: Union Ordering) + Just (ssymBool "a") .<= Nothing .@?= conBool False + Just (ssymBool "a") .< Nothing .@?= conBool False + Just (ssymBool "a") .>= Nothing .@?= conBool True + Just (ssymBool "a") .> Nothing .@?= conBool True + Just (ssymBool "a") + `symCompare` Nothing + @?= (mrgSingle GT :: Union Ordering) + Just (ssymBool "a") + .<= Just (ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + Just (ssymBool "a") + .< Just (ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + Just (ssymBool "a") + .>= Just (ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + Just (ssymBool "a") + .> Just (ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + Just (ssymBool "a") + `symCompare` Just (ssymBool "b") + @?= ( ssymBool "a" `symCompare` ssymBool "b" :: + Union Ordering + ) + ], + testGroup + "MaybeT" + [ testProperty "MaybeT Maybe Integer" $ + ioProperty + . concreteOrdOkProp @(MaybeT Maybe Integer) + . bimap MaybeT MaybeT, + testCase "MaybeT Maybe SymBool" $ do + (MaybeT Nothing :: MaybeT Maybe SymBool) + .<= MaybeT Nothing + .@?= conBool True + (MaybeT Nothing :: MaybeT Maybe SymBool) + .<= MaybeT (Just (Just (ssymBool "a"))) + .@?= conBool True + MaybeT (Just (Just (ssymBool "a"))) + .<= (MaybeT Nothing :: MaybeT Maybe SymBool) + .@?= conBool False + MaybeT (Just (Just (ssymBool "a"))) + .<= ( MaybeT (Just (Just (ssymBool "b"))) :: + MaybeT Maybe SymBool + ) + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + + (MaybeT Nothing :: MaybeT Maybe SymBool) + .< MaybeT Nothing + .@?= conBool False + (MaybeT Nothing :: MaybeT Maybe SymBool) + .< MaybeT (Just (Just (ssymBool "a"))) + .@?= conBool True + MaybeT (Just (Just (ssymBool "a"))) + .< (MaybeT Nothing :: MaybeT Maybe SymBool) + .@?= conBool False + MaybeT (Just (Just (ssymBool "a"))) + .< ( MaybeT (Just (Just (ssymBool "b"))) :: + MaybeT Maybe SymBool + ) + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + + (MaybeT Nothing :: MaybeT Maybe SymBool) + .>= MaybeT Nothing + .@?= conBool True + (MaybeT Nothing :: MaybeT Maybe SymBool) + .>= MaybeT (Just (Just (ssymBool "a"))) + .@?= conBool False + MaybeT (Just (Just (ssymBool "a"))) + .>= (MaybeT Nothing :: MaybeT Maybe SymBool) + .@?= conBool True + MaybeT (Just (Just (ssymBool "a"))) + .>= ( MaybeT (Just (Just (ssymBool "b"))) :: + MaybeT Maybe SymBool + ) + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + + (MaybeT Nothing :: MaybeT Maybe SymBool) + .> MaybeT Nothing + .@?= conBool False + (MaybeT Nothing :: MaybeT Maybe SymBool) + .> MaybeT (Just (Just (ssymBool "a"))) + .@?= conBool False + MaybeT (Just (Just (ssymBool "a"))) + .> (MaybeT Nothing :: MaybeT Maybe SymBool) + .@?= conBool True + MaybeT (Just (Just (ssymBool "a"))) + .> ( MaybeT (Just (Just (ssymBool "b"))) :: + MaybeT Maybe SymBool + ) + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + + (MaybeT Nothing :: MaybeT Maybe SymBool) + `symCompare` MaybeT Nothing + @?= (mrgSingle EQ :: Union Ordering) + (MaybeT Nothing :: MaybeT Maybe SymBool) + `symCompare` MaybeT (Just (Just (ssymBool "a"))) + @?= (mrgSingle LT :: Union Ordering) + MaybeT (Just (Just (ssymBool "a"))) + `symCompare` (MaybeT Nothing :: MaybeT Maybe SymBool) + @?= (mrgSingle GT :: Union Ordering) + MaybeT (Just (Just (ssymBool "a"))) + `symCompare` ( MaybeT (Just (Just (ssymBool "b"))) :: + MaybeT Maybe SymBool + ) + @?= ( ssymBool "a" `symCompare` ssymBool "b" :: + Union Ordering + ) + ], + testGroup + "Either" + [ testProperty "Either Integer Integer" $ + ioProperty . concreteOrdOkProp @(Either Integer Integer), + testCase "Either SymBool SymBool" $ do + (Left (ssymBool "a") :: Either SymBool SymBool) + .<= Left (ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + (Left (ssymBool "a") :: Either SymBool SymBool) + .< Left (ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + (Left (ssymBool "a") :: Either SymBool SymBool) + .>= Left (ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + (Left (ssymBool "a") :: Either SymBool SymBool) + .> Left (ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + (Left (ssymBool "a") :: Either SymBool SymBool) + `symCompare` Left (ssymBool "b") + @?= (ssymBool "a" `symCompare` ssymBool "b") + (Left (ssymBool "a") :: Either SymBool SymBool) + .<= Right (ssymBool "b") + .@?= conBool True + (Left (ssymBool "a") :: Either SymBool SymBool) + .< Right (ssymBool "b") + .@?= conBool True + (Left (ssymBool "a") :: Either SymBool SymBool) + .>= Right (ssymBool "b") + .@?= conBool False + (Left (ssymBool "a") :: Either SymBool SymBool) + .> Right (ssymBool "b") + .@?= conBool False + (Left (ssymBool "a") :: Either SymBool SymBool) + `symCompare` Right (ssymBool "b") + @?= (mrgSingle LT :: Union Ordering) + (Right (ssymBool "a") :: Either SymBool SymBool) + .<= Left (ssymBool "b") + .@?= conBool False + (Right (ssymBool "a") :: Either SymBool SymBool) + .< Left (ssymBool "b") + .@?= conBool False + (Right (ssymBool "a") :: Either SymBool SymBool) + .>= Left (ssymBool "b") + .@?= conBool True + (Right (ssymBool "a") :: Either SymBool SymBool) + .> Left (ssymBool "b") + .@?= conBool True + (Right (ssymBool "a") :: Either SymBool SymBool) + `symCompare` Left (ssymBool "b") + @?= (mrgSingle GT :: Union Ordering) + (Right (ssymBool "a") :: Either SymBool SymBool) + .<= Right (ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + (Right (ssymBool "a") :: Either SymBool SymBool) + .< Right (ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + (Right (ssymBool "a") :: Either SymBool SymBool) + .>= Right (ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + (Right (ssymBool "a") :: Either SymBool SymBool) + .> Right (ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + (Right (ssymBool "a") :: Either SymBool SymBool) + `symCompare` Right (ssymBool "b") + @?= (ssymBool "a" `symCompare` ssymBool "b") + ], + testGroup + "ExceptT" + [ testProperty + "ExceptT Integer Maybe Integer" + $ ioProperty + . concreteOrdOkProp @(ExceptT Integer Maybe Integer) + . bimap ExceptT ExceptT, + testCase "ExceptT SymBool Maybe SymBool" $ do + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .<= ExceptT Nothing + .@?= conBool True + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .<= ExceptT (Just (Left (ssymBool "a"))) + .@?= conBool True + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .<= ExceptT (Just (Right (ssymBool "a"))) + .@?= conBool True + ExceptT (Just (Left (ssymBool "a"))) + .<= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .@?= conBool False + ExceptT (Just (Right (ssymBool "a"))) + .<= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .@?= conBool False + ExceptT (Just (Left (ssymBool "a"))) + .<= ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + ExceptT (Just (Right (ssymBool "a"))) + .<= ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= conBool False + ExceptT (Just (Left (ssymBool "a"))) + .<= ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= conBool True + ExceptT (Just (Right (ssymBool "a"))) + .<= ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .< ExceptT Nothing + .@?= conBool False + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .< ExceptT (Just (Left (ssymBool "a"))) + .@?= conBool True + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .< ExceptT (Just (Right (ssymBool "a"))) + .@?= conBool True + ExceptT (Just (Left (ssymBool "a"))) + .< (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .@?= conBool False + ExceptT (Just (Right (ssymBool "a"))) + .< (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .@?= conBool False + ExceptT (Just (Left (ssymBool "a"))) + .< ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + ExceptT (Just (Right (ssymBool "a"))) + .< ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= conBool False + ExceptT (Just (Left (ssymBool "a"))) + .< ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= conBool True + ExceptT (Just (Right (ssymBool "a"))) + .< ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .>= ExceptT Nothing + .@?= conBool True + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .>= ExceptT (Just (Left (ssymBool "a"))) + .@?= conBool False + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .>= ExceptT (Just (Right (ssymBool "a"))) + .@?= conBool False + ExceptT (Just (Left (ssymBool "a"))) + .>= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .@?= conBool True + ExceptT (Just (Right (ssymBool "a"))) + .>= (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .@?= conBool True + ExceptT (Just (Left (ssymBool "a"))) + .>= ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + ExceptT (Just (Right (ssymBool "a"))) + .>= ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= conBool True + ExceptT (Just (Left (ssymBool "a"))) + .>= ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= conBool False + ExceptT (Just (Right (ssymBool "a"))) + .>= ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .> ExceptT Nothing + .@?= conBool False + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .> ExceptT (Just (Left (ssymBool "a"))) + .@?= conBool False + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .> ExceptT (Just (Right (ssymBool "a"))) + .@?= conBool False + ExceptT (Just (Left (ssymBool "a"))) + .> (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .@?= conBool True + ExceptT (Just (Right (ssymBool "a"))) + .> (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + .@?= conBool True + ExceptT (Just (Left (ssymBool "a"))) + .> ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + ExceptT (Just (Right (ssymBool "a"))) + .> ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= conBool True + ExceptT (Just (Left (ssymBool "a"))) + .> ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= conBool False + ExceptT (Just (Right (ssymBool "a"))) + .> ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + `symCompare` ExceptT Nothing + @?= (mrgSingle EQ :: Union Ordering) + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + `symCompare` ExceptT (Just (Left (ssymBool "a"))) + @?= (mrgSingle LT :: Union Ordering) + (ExceptT Nothing :: ExceptT SymBool Maybe SymBool) + `symCompare` ExceptT (Just (Right (ssymBool "a"))) + @?= (mrgSingle LT :: Union Ordering) + ExceptT (Just (Left (ssymBool "a"))) + `symCompare` ( ExceptT Nothing :: + ExceptT SymBool Maybe SymBool + ) + @?= (mrgSingle GT :: Union Ordering) + ExceptT (Just (Right (ssymBool "a"))) + `symCompare` ( ExceptT Nothing :: + ExceptT SymBool Maybe SymBool + ) + @?= (mrgSingle GT :: Union Ordering) + ExceptT (Just (Left (ssymBool "a"))) + `symCompare` ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + @?= (ssymBool "a" `symCompare` ssymBool "b" :: Union Ordering) + ExceptT (Just (Right (ssymBool "a"))) + `symCompare` ( ExceptT (Just (Left (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + @?= (mrgSingle GT :: Union Ordering) + ExceptT (Just (Left (ssymBool "a"))) + `symCompare` ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + @?= (mrgSingle LT :: Union Ordering) + ExceptT (Just (Right (ssymBool "a"))) + `symCompare` ( ExceptT (Just (Right (ssymBool "b"))) :: + ExceptT SymBool Maybe SymBool + ) + @?= ( ssymBool "a" `symCompare` ssymBool "b" :: + Union Ordering + ) + ], + testProperty "()" (ioProperty . concreteOrdOkProp @()), + testGroup + "(,)" + [ testProperty "(Integer, Integer)" $ + ioProperty . concreteOrdOkProp @(Integer, Integer), + testCase "(SymBool, SymBool)" $ do + let l = (ssymBool "a", ssymBool "c") + let r = (ssymBool "b", ssymBool "d") + let ll = ssymBool "a" + let lr = ssymBool "c" + let rl = ssymBool "b" + let rr = ssymBool "d" + symbolicProdOrdOkProp l r ll lr rl rr + ], + testGroup + "(,,)" + [ testProperty "(Integer, Integer, Integer)" $ + ioProperty . concreteOrdOkProp @(Integer, Integer, Integer), + testCase "(SymBool, SymBool, SymBool)" $ do + let l = (ssymBool "a", ssymBool "c", ssymBool "e") + let r = (ssymBool "b", ssymBool "d", ssymBool "f") + let ll = ssymBool "a" + let lr = (ssymBool "c", ssymBool "e") + let rl = ssymBool "b" + let rr = (ssymBool "d", ssymBool "f") + symbolicProdOrdOkProp l r ll lr rl rr + ], + testGroup + "(,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteOrdOkProp @(Integer, Integer, Integer, Integer), + testCase "(SymBool, SymBool, SymBool, SymBool)" $ do + let l = (ssymBool "a", ssymBool "c", ssymBool "e", ssymBool "g") + let r = (ssymBool "b", ssymBool "d", ssymBool "f", ssymBool "h") + let ll = (ssymBool "a", ssymBool "c") + let lr = (ssymBool "e", ssymBool "g") + let rl = (ssymBool "b", ssymBool "d") + let rr = (ssymBool "f", ssymBool "h") + symbolicProdOrdOkProp l r ll lr rl rr + ], + testGroup + "(,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteOrdOkProp + @(Integer, Integer, Integer, Integer, Integer), + testCase "(SymBool, SymBool, SymBool, SymBool, SymBool)" $ do + let l = + ( ssymBool "a", + ssymBool "c", + ssymBool "e", + ssymBool "g", + ssymBool "i" + ) + let r = + ( ssymBool "b", + ssymBool "d", + ssymBool "f", + ssymBool "h", + ssymBool "j" + ) + let ll = (ssymBool "a", ssymBool "c") + let lr = (ssymBool "e", ssymBool "g", ssymBool "i") + let rl = (ssymBool "b", ssymBool "d") + let rr = (ssymBool "f", ssymBool "h", ssymBool "j") + symbolicProdOrdOkProp l r ll lr rl rr + ], + testGroup + "(,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteOrdOkProp + @( Integer, + Integer, + Integer, + Integer, + Integer, + Integer + ), + testCase + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + $ do + let l = + ( ssymBool "a", + ssymBool "c", + ssymBool "e", + ssymBool "g", + ssymBool "i", + ssymBool "k" + ) + let r = + ( ssymBool "b", + ssymBool "d", + ssymBool "f", + ssymBool "h", + ssymBool "j", + ssymBool "l" + ) + let ll = (ssymBool "a", ssymBool "c", ssymBool "e") + let lr = (ssymBool "g", ssymBool "i", ssymBool "k") + let rl = (ssymBool "b", ssymBool "d", ssymBool "f") + let rr = (ssymBool "h", ssymBool "j", ssymBool "l") + symbolicProdOrdOkProp l r ll lr rl rr + ], + testGroup + "(,,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer, Integer)" + $ ioProperty + . concreteOrdOkProp @(Integer, Integer, Integer, Integer, Integer, Integer, Integer), + testCase + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + $ do + let l = + ( ssymBool "a", + ssymBool "c", + ssymBool "e", + ssymBool "g", + ssymBool "i", + ssymBool "k", + ssymBool "m" + ) + let r = + ( ssymBool "b", + ssymBool "d", + ssymBool "f", + ssymBool "h", + ssymBool "j", + ssymBool "l", + ssymBool "n" + ) + let ll = (ssymBool "a", ssymBool "c", ssymBool "e") + let lr = + ( ssymBool "g", + ssymBool "i", + ssymBool "k", + ssymBool "m" + ) + let rl = (ssymBool "b", ssymBool "d", ssymBool "f") + let rr = + ( ssymBool "h", + ssymBool "j", + ssymBool "l", + ssymBool "n" + ) + symbolicProdOrdOkProp l r ll lr rl rr + ], + testGroup + "(,,,,,,,)" + [ testProperty + "(Integer, Integer, Integer, Integer, Integer, Integer, Integer, Integer)" + ( ioProperty + . concreteOrdOkProp + @( Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer, + Integer + ) + ), + testCase + "(SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool, SymBool)" + $ do + let l = + ( ssymBool "a", + ssymBool "c", + ssymBool "e", + ssymBool "g", + ssymBool "i", + ssymBool "k", + ssymBool "m", + ssymBool "o" + ) + let r = + ( ssymBool "b", + ssymBool "d", + ssymBool "f", + ssymBool "h", + ssymBool "j", + ssymBool "l", + ssymBool "n", + ssymBool "p" + ) + let ll = + ( ssymBool "a", + ssymBool "c", + ssymBool "e", + ssymBool "g" + ) + let lr = + ( ssymBool "i", + ssymBool "k", + ssymBool "m", + ssymBool "o" + ) + let rl = + ( ssymBool "b", + ssymBool "d", + ssymBool "f", + ssymBool "h" + ) + let rr = + ( ssymBool "j", + ssymBool "l", + ssymBool "n", + ssymBool "p" + ) + symbolicProdOrdOkProp l r ll lr rl rr + ], + testGroup + "Sum" + [ testProperty + "Sum Maybe Maybe Integer" + ( ioProperty . \v -> + let eitherToSum :: + Either (Maybe Integer) (Maybe Integer) -> + Sum Maybe Maybe Integer + eitherToSum (Left x) = InL x + eitherToSum (Right x) = InR x + in concreteOrdOkProp (bimap eitherToSum eitherToSum v) + ), + testCase "Sum Maybe Maybe SymBool" $ do + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .<= InL (Just $ ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .< InL (Just $ ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .>= InL (Just $ ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .> InL (Just $ ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .<= InR (Just $ ssymBool "b") + .@?= conBool True + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .< InR (Just $ ssymBool "b") + .@?= conBool True + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .>= InR (Just $ ssymBool "b") + .@?= conBool False + (InL $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .> InR (Just $ ssymBool "b") + .@?= conBool False + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .<= InR (Just $ ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .< InR (Just $ ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .>= InR (Just $ ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .> InR (Just $ ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .<= InL (Just $ ssymBool "b") + .@?= conBool False + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .< InL (Just $ ssymBool "b") + .@?= conBool False + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .>= InL (Just $ ssymBool "b") + .@?= conBool True + (InR $ Just $ ssymBool "a" :: Sum Maybe Maybe SymBool) + .> InL (Just $ ssymBool "b") + .@?= conBool True + ], + testGroup + "WriterT" + [ testGroup + "Lazy" + [ testProperty + "WriterT Integer (Either Integer) Integer" + ( ioProperty + . \( v1 :: Either Integer (Integer, Integer), + v2 :: Either Integer (Integer, Integer) + ) -> + concreteOrdOkProp + ( WriterLazy.WriterT v1, + WriterLazy.WriterT v2 + ) + ), + testCase "WriterT SymBool (Either SymBool) SymBool" $ do + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .<= WriterLazy.WriterT (Left $ ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .< WriterLazy.WriterT (Left $ ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .>= WriterLazy.WriterT (Left $ ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .> WriterLazy.WriterT (Left $ ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + `symCompare` WriterLazy.WriterT (Left $ ssymBool "b") + @?= ( ssymBool "a" `symCompare` ssymBool "b" :: + Union Ordering + ) + + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .<= WriterLazy.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= conBool True + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .< WriterLazy.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= conBool True + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .>= WriterLazy.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= conBool False + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .> WriterLazy.WriterT (Right (ssymBool "b", ssymBool "d")) + .@?= conBool False + ( WriterLazy.WriterT $ Left $ ssymBool "a" :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + `symCompare` WriterLazy.WriterT + (Right (ssymBool "b", ssymBool "d")) + @?= (mrgSingle LT :: Union Ordering) + + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .<= WriterLazy.WriterT (Left $ ssymBool "b") + .@?= conBool False + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .< WriterLazy.WriterT (Left $ ssymBool "b") + .@?= conBool False + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .>= WriterLazy.WriterT (Left $ ssymBool "b") + .@?= conBool True + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .> WriterLazy.WriterT (Left $ ssymBool "b") + .@?= conBool True + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + `symCompare` WriterLazy.WriterT (Left $ ssymBool "b") + @?= (mrgSingle GT :: Union Ordering) + + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .<= WriterLazy.WriterT (Right (ssymBool "b", ssymBool "d")) + .@?= ( (ssymBool "a", ssymBool "c") + .<= (ssymBool "b", ssymBool "d") :: + SymBool + ) + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .< WriterLazy.WriterT (Right (ssymBool "b", ssymBool "d")) + .@?= ( (ssymBool "a", ssymBool "c") + .< (ssymBool "b", ssymBool "d") :: + SymBool + ) + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .>= WriterLazy.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= ( (ssymBool "a", ssymBool "c") + .>= (ssymBool "b", ssymBool "d") :: + SymBool + ) + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + .> WriterLazy.WriterT (Right (ssymBool "b", ssymBool "d")) + .@?= ( (ssymBool "a", ssymBool "c") + .> (ssymBool "b", ssymBool "d") :: + SymBool + ) + ( WriterLazy.WriterT $ Right (ssymBool "a", ssymBool "c") :: + WriterLazy.WriterT SymBool (Either SymBool) SymBool + ) + `symCompare` WriterLazy.WriterT + (Right (ssymBool "b", ssymBool "d")) + @?= ( (ssymBool "a", ssymBool "c") + `symCompare` (ssymBool "b", ssymBool "d") :: + Union Ordering + ) + ], + testGroup + "Strict" + [ testProperty + "WriterT Integer (Either Integer) Integer" + ( ioProperty + . \( v1 :: Either Integer (Integer, Integer), + v2 :: Either Integer (Integer, Integer) + ) -> + concreteOrdOkProp + ( WriterStrict.WriterT v1, + WriterStrict.WriterT v2 + ) + ), + testCase "WriterT Integer (Either Integer) Integer" $ do + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .<= WriterStrict.WriterT (Left $ ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .< WriterStrict.WriterT (Left $ ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .>= WriterStrict.WriterT (Left $ ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .> WriterStrict.WriterT (Left $ ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + `symCompare` WriterStrict.WriterT (Left $ ssymBool "b") + @?= ( ssymBool "a" `symCompare` ssymBool "b" :: + Union Ordering + ) + + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .<= WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= conBool True + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .< WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= conBool True + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .>= WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= conBool False + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .> WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= conBool False + ( WriterStrict.WriterT $ Left $ ssymBool "a" :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + `symCompare` WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + @?= (mrgSingle LT :: Union Ordering) + + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .<= WriterStrict.WriterT (Left $ ssymBool "b") + .@?= conBool False + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .< WriterStrict.WriterT (Left $ ssymBool "b") + .@?= conBool False + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .>= WriterStrict.WriterT (Left $ ssymBool "b") + .@?= conBool True + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .> WriterStrict.WriterT (Left $ ssymBool "b") + .@?= conBool True + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + `symCompare` WriterStrict.WriterT (Left $ ssymBool "b") + @?= (mrgSingle GT :: Union Ordering) + + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .<= WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= ( (ssymBool "a", ssymBool "c") + .<= (ssymBool "b", ssymBool "d") :: + SymBool + ) + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .< WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= ( (ssymBool "a", ssymBool "c") + .< (ssymBool "b", ssymBool "d") :: + SymBool + ) + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .>= WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= ( (ssymBool "a", ssymBool "c") + .>= (ssymBool "b", ssymBool "d") :: + SymBool + ) + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + .> WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + .@?= ( (ssymBool "a", ssymBool "c") + .> (ssymBool "b", ssymBool "d") :: + SymBool + ) + ( WriterStrict.WriterT $ + Right (ssymBool "a", ssymBool "c") :: + WriterStrict.WriterT SymBool (Either SymBool) SymBool + ) + `symCompare` WriterStrict.WriterT + (Right (ssymBool "b", ssymBool "d")) + @?= ( (ssymBool "a", ssymBool "c") + `symCompare` (ssymBool "b", ssymBool "d") :: + Union Ordering + ) + ] + ], + testGroup + "Identity" + [ testProperty + "Identity Integer" + ( ioProperty . \(v1 :: Integer, v2) -> + concreteOrdOkProp (Identity v1, Identity v2) + ), + testCase "Identity SymBool" $ do + (Identity $ ssymBool "a" :: Identity SymBool) + .<= Identity (ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + (Identity $ ssymBool "a" :: Identity SymBool) + .< Identity (ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + (Identity $ ssymBool "a" :: Identity SymBool) + .>= Identity (ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + (Identity $ ssymBool "a" :: Identity SymBool) + .> Identity (ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + ], + testGroup + "IdentityT" + [ testProperty + "IdentityT (Either Integer) Integer" + ( ioProperty . \(v1 :: Either Integer Integer, v2) -> + concreteOrdOkProp (IdentityT v1, IdentityT v2) + ), + testCase "IdentityT (Either SymBool) SymBool" $ do + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .<= IdentityT (Left $ ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .< IdentityT (Left $ ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .>= IdentityT (Left $ ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .> IdentityT (Left $ ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + `symCompare` IdentityT (Left $ ssymBool "b") + @?= (ssymBool "a" `symCompare` ssymBool "b") + + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .<= IdentityT (Right $ ssymBool "b") + .@?= conBool True + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .< IdentityT (Right $ ssymBool "b") + .@?= conBool True + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .>= IdentityT (Right $ ssymBool "b") + .@?= conBool False + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .> IdentityT (Right $ ssymBool "b") + .@?= conBool False + ( IdentityT $ Left $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + `symCompare` IdentityT (Right $ ssymBool "b") + @?= (mrgSingle LT :: Union Ordering) + + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .<= IdentityT (Left $ ssymBool "b") + .@?= conBool False + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .< IdentityT (Left $ ssymBool "b") + .@?= conBool False + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .>= IdentityT (Left $ ssymBool "b") + .@?= conBool True + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .> IdentityT (Left $ ssymBool "b") + .@?= conBool True + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + `symCompare` IdentityT (Left $ ssymBool "b") + @?= (mrgSingle GT :: Union Ordering) + + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .<= IdentityT (Right $ ssymBool "b") + .@?= (ssymBool "a" .<= ssymBool "b" :: SymBool) + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .< IdentityT (Right $ ssymBool "b") + .@?= (ssymBool "a" .< ssymBool "b" :: SymBool) + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .>= IdentityT (Right $ ssymBool "b") + .@?= (ssymBool "a" .>= ssymBool "b" :: SymBool) + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + .> IdentityT (Right $ ssymBool "b") + .@?= (ssymBool "a" .> ssymBool "b" :: SymBool) + ( IdentityT $ Right $ ssymBool "a" :: + IdentityT (Either SymBool) SymBool + ) + `symCompare` IdentityT (Right $ ssymBool "b") + @?= (ssymBool "a" `symCompare` ssymBool "b") + ], + testCase "ByteString" $ do + let bytestrings :: [B.ByteString] = + ["", "a", "b", "ab", "ba", "aa", "bb"] + traverse_ + concreteOrdOkProp + [(x, y) | x <- bytestrings, y <- bytestrings] + ], + testCase "symMax" $ do + symMax (1 :: SymInteger) 2 @?= 2 + let [a, b] = ["a", "b"] :: [SymInteger] + symMax a b .@?= symIte (a .>= b) a b, + testCase "symMin" $ do + symMin (1 :: SymInteger) 2 @?= 1 + let [a, b] = ["a", "b"] :: [SymInteger] + symMin a b .@?= symIte (a .>= b) b a, + testCase "mrgMax" $ do + mrgMax [1] [0, 3] @?= (mrgReturn [1] :: Union [SymInteger]) + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + (mrgMax [a] [b, c] :: Union [SymInteger]) + .@?= (mrgIf (a .<= b) (return [b, c]) (return [a])), + testCase "mrgMin" $ do + mrgMin [1] [0, 3] @?= (mrgReturn [0, 3] :: Union [SymInteger]) + let [a, b, c] = ["a", "b", "c"] :: [SymInteger] + (mrgMin [a] [b, c] :: Union [SymInteger]) + .@?= (mrgIf (b .< a) (return [b, c]) (return [a])) + ] diff --git a/test/Grisette/Core/Data/Class/ToConTests.hs b/test/Grisette/Core/Data/Class/ToConTests.hs --- a/test/Grisette/Core/Data/Class/ToConTests.hs +++ b/test/Grisette/Core/Data/Class/ToConTests.hs @@ -21,8 +21,8 @@ import Grisette ( ITEOp (symIte), LogicalOp (symNot, (.&&), (.||)), - SEq ((.==)), SymBool, + SymEq ((.==)), ToCon (toCon), ) import Grisette.Core.Data.Class.TestValues @@ -38,8 +38,7 @@ import Test.HUnit (Assertion, (@?=)) import Test.QuickCheck (ioProperty) -toConForConcreteOkProp :: - (HasCallStack, ToCon v v, Show v, Eq v) => v -> Assertion +toConForConcreteOkProp :: (HasCallStack, Show v, Eq v) => v -> Assertion toConForConcreteOkProp v = toCon v @?= Just v toConTests :: Test diff --git a/test/Grisette/Core/Data/Class/ToSymTests.hs b/test/Grisette/Core/Data/Class/ToSymTests.hs --- a/test/Grisette/Core/Data/Class/ToSymTests.hs +++ b/test/Grisette/Core/Data/Class/ToSymTests.hs @@ -24,9 +24,9 @@ import Grisette ( ITEOp (symIte), LogicalOp (symNot, (.&&), (.||)), - SEq ((.==)), Solvable (con, isym, ssym), SymBool, + SymEq ((.==)), ToSym (toSym), ) import Test.Framework (Test, testGroup) @@ -35,8 +35,7 @@ import Test.HUnit (Assertion, (@?=)) import Test.QuickCheck (ioProperty) -toSymForConcreteOkProp :: - (HasCallStack, ToSym v v, Show v, Eq v) => v -> Assertion +toSymForConcreteOkProp :: (HasCallStack, Show v, Eq v) => v -> Assertion toSymForConcreteOkProp v = toSym v @?= v toSymTests :: Test diff --git a/test/Grisette/Core/Data/Class/TryMergeTests.hs b/test/Grisette/Core/Data/Class/TryMergeTests.hs --- a/test/Grisette/Core/Data/Class/TryMergeTests.hs +++ b/test/Grisette/Core/Data/Class/TryMergeTests.hs @@ -19,13 +19,13 @@ import Grisette ( ITEOp (symIte), Mergeable (rootStrategy), + SymBranching (mrgIfPropagatedStrategy), TryMerge, - UnionMergeable1 (mrgIfPropagatedStrategy), mrgSingle, tryMerge, ) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM (UMrg)) -import Grisette.Internal.Core.Data.Union (Union (UnionSingle)) +import Grisette.Internal.Core.Control.Monad.Union (Union (UMrg)) +import Grisette.Internal.Core.Data.UnionBase (UnionBase (UnionSingle)) import Grisette.Internal.SymPrim.SymInteger (SymInteger) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) @@ -41,7 +41,7 @@ } -> TryMergeInstanceTest -unmergedUnion :: UnionM SymInteger +unmergedUnion :: Union SymInteger unmergedUnion = mrgIfPropagatedStrategy "a" @@ -53,13 +53,13 @@ testGroup "TryMerge" [ testCase "mrgSingle" $ do - let actual = mrgSingle 1 :: UnionM Integer + let actual = mrgSingle 1 :: Union Integer actual @?= (UMrg rootStrategy (UnionSingle 1)), testCase "mrgSingle" $ do - let actual = mrgSingle 1 :: UnionM Integer + let actual = mrgSingle 1 :: Union Integer actual @?= (UMrg rootStrategy (UnionSingle 1)), testCase "tryMerge" $ do - let actual = tryMerge $ return 1 :: UnionM Integer + let actual = tryMerge $ return 1 :: Union Integer actual @?= (UMrg rootStrategy (UnionSingle 1)), testGroup "Instances" $ do test <- @@ -72,7 +72,7 @@ { testName = "ExceptT", testUnmerged = ExceptT $ Right <$> unmergedUnion :: - ExceptT SymInteger UnionM SymInteger, + ExceptT SymInteger Union SymInteger, testMerged = ExceptT (mrgSingle $ Right $ symIte "a" "b" "c") }, TryMergeInstanceTest @@ -87,7 +87,7 @@ StateLazy.runStateT (StateLazy.StateT $ \s -> (,s) <$> unmergedUnion) "x" :: - UnionM (SymInteger, SymInteger), + Union (SymInteger, SymInteger), testMerged = mrgSingle (symIte "a" "b" "c", "x") }, TryMergeInstanceTest @@ -96,7 +96,7 @@ StateStrict.runStateT (StateStrict.StateT $ \s -> (,s) <$> unmergedUnion) "x" :: - UnionM (SymInteger, SymInteger), + Union (SymInteger, SymInteger), testMerged = mrgSingle (symIte "a" "b" "c", "x") }, TryMergeInstanceTest @@ -106,7 +106,7 @@ ( WriterLazy.WriterT $ (\x -> (x, x + 1)) <$> unmergedUnion ) :: - UnionM (SymInteger, SymInteger), + Union (SymInteger, SymInteger), testMerged = mrgSingle (symIte "a" "b" "c", symIte "a" ("b" + 1) ("c" + 1)) }, @@ -117,7 +117,7 @@ ( WriterStrict.WriterT $ (\x -> (x, x + 1)) <$> unmergedUnion ) :: - UnionM (SymInteger, SymInteger), + Union (SymInteger, SymInteger), testMerged = mrgSingle (symIte "a" "b" "c", symIte "a" ("b" + 1) ("c" + 1)) }, @@ -130,7 +130,7 @@ ) "r" "s" :: - UnionM (SymInteger, SymInteger, SymInteger), + Union (SymInteger, SymInteger, SymInteger), testMerged = mrgSingle (symIte "a" "b" "c", "s", "r") }, TryMergeInstanceTest @@ -142,7 +142,7 @@ ) "r" "s" :: - UnionM (SymInteger, SymInteger, SymInteger), + Union (SymInteger, SymInteger, SymInteger), testMerged = mrgSingle (symIte "a" "b" "c", "s", "r") }, TryMergeInstanceTest diff --git a/test/Grisette/Core/Data/UnionBaseTests.hs b/test/Grisette/Core/Data/UnionBaseTests.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/Data/UnionBaseTests.hs @@ -0,0 +1,839 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module Grisette.Core.Data.UnionBaseTests (unionBaseTests) where + +import GHC.Generics (Generic) +import Grisette + ( ITEOp (symIte), + LogicalOp (symNot, (.&&), (.||)), + Mergeable (rootStrategy), + MergingStrategy (SortedStrategy), + Solvable (con), + SymInteger, + wrapStrategy, + ) +import Grisette.Internal.Core.Data.UnionBase + ( UnionBase (UnionIf, UnionSingle), + fullReconstruct, + ifWithLeftMost, + ifWithStrategy, + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +data TripleSum a b c = TS1 a | TS2 b | TS3 c deriving (Show, Eq, Generic) + +instance + (Mergeable a, Mergeable b, Mergeable c) => + Mergeable (TripleSum a b c) + where + rootStrategy = + SortedStrategy + (\case TS1 _ -> (0 :: Int); TS2 _ -> (1 :: Int); TS3 _ -> (2 :: Int)) + ( \case + 0 -> wrapStrategy rootStrategy TS1 (\(TS1 x) -> x) + 1 -> wrapStrategy rootStrategy TS2 (\(TS2 x) -> x) + 2 -> wrapStrategy rootStrategy TS3 (\(TS3 x) -> x) + _ -> error "Bad" + ) + +unionBaseTests :: Test +unionBaseTests = + testGroup + "UnionBase" + [ testGroup + "ifWithLeftMost" + [ testCase + "ifWithLeftMost should maintain left most info on Singles" + $ do + ifWithLeftMost + False + "a" + (UnionSingle (1 :: Integer)) + (UnionSingle 2) + @?= UnionIf 1 False "a" (UnionSingle 1) (UnionSingle 2), + testCase "ifWithLeftMost should maintain left most info on Ifs" $ do + ifWithLeftMost + True + "a" + (UnionIf 1 True "b" (UnionSingle (1 :: Integer)) (UnionSingle 2)) + (UnionIf 3 True "c" (UnionSingle 3) (UnionSingle 4)) + @?= UnionIf + 1 + True + "a" + ( UnionIf + 1 + True + "b" + (UnionSingle (1 :: Integer)) + (UnionSingle 2) + ) + (UnionIf 3 True "c" (UnionSingle 3) (UnionSingle 4)) + ], + testGroup + "ifWithStrategy" + [ testGroup + "ifWithStrategy with concrete condition" + [ testCase "true" $ do + ifWithStrategy + rootStrategy + (con True) + (UnionSingle (1 :: Integer)) + (UnionSingle 2) + @?= UnionSingle 1, + testCase "false" $ do + ifWithStrategy + rootStrategy + (con False) + (UnionSingle (1 :: Integer)) + (UnionSingle 2) + @?= UnionSingle 2 + ], + let a = + ifWithStrategy + rootStrategy + "a" + (UnionSingle (1 :: Integer)) + (UnionSingle 2) + in testGroup + "ifWithStrategy with condition equal to sub conditions" + [ testCase "ifTrue" $ do + ifWithStrategy rootStrategy "a" a (UnionSingle 3) + @?= UnionIf 1 True "a" (UnionSingle 1) (UnionSingle 3), + testCase "ifFalse" $ do + ifWithStrategy rootStrategy "a" (UnionSingle 0) a + @?= UnionIf 0 True "a" (UnionSingle 0) (UnionSingle 2) + ], + testCase "ifWithStrategy with simple mergeables" $ do + ifWithStrategy + rootStrategy + "a" + (UnionSingle ("b" :: SymInteger)) + (UnionSingle "c") + @?= UnionSingle (symIte "a" "b" "c"), + testGroup + "ifWithStrategy with ordered mergeables" + [ testGroup + "ifWithStrategy on Single/Single" + [ testGroup + "idxt < idxf" + [ testCase "Integer" $ + ifWithStrategy + rootStrategy + "a" + (UnionSingle (1 :: Integer)) + (UnionSingle 2) + @?= UnionIf + 1 + True + "a" + (UnionSingle 1) + (UnionSingle 2), + testCase "Maybe Integer" $ + ifWithStrategy + rootStrategy + "a" + (UnionSingle Nothing) + (UnionSingle (Just (2 :: Integer))) + @?= UnionIf + Nothing + True + "a" + (UnionSingle Nothing) + (UnionSingle (Just 2)) + ], + testGroup + "idxt == idxf" + [ testGroup + "idxt == idxf as terminal" + [ testCase "Integer" $ + ifWithStrategy + rootStrategy + "a" + (UnionSingle (1 :: Integer)) + (UnionSingle 1) + @?= UnionSingle 1, + testCase "Maybe Integer" $ + ifWithStrategy + rootStrategy + "a" + (UnionSingle (Just ("b" :: SymInteger))) + (UnionSingle (Just "c")) + @?= UnionSingle (Just (symIte "a" "b" "c")) + ], + testGroup + "idxt == idxf but not terminal" + [ testCase "Maybe Integer" $ + ifWithStrategy + rootStrategy + "a" + (UnionSingle (Just (1 :: Integer))) + (UnionSingle (Just (2 :: Integer))) + @?= UnionIf + (Just 1) + True + "a" + (UnionSingle $ Just 1) + (UnionSingle (Just 2)), + testCase "Maybe (Maybe Integer)" $ + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ Just $ Just ("b" :: SymInteger)) + (UnionSingle $ Just $ Just "c") + @?= UnionSingle (Just (Just (symIte "a" "b" "c"))) + ] + ], + testGroup + "idxt > idxf" + [ testCase "Integer" $ + ifWithStrategy + rootStrategy + "a" + (UnionSingle (2 :: Integer)) + (UnionSingle 1) + @?= UnionIf + 1 + True + (symNot "a") + (UnionSingle 1) + (UnionSingle 2), + testCase "Maybe Integer" $ + ifWithStrategy + rootStrategy + "a" + (UnionSingle (Just (2 :: Integer))) + (UnionSingle Nothing) + @?= UnionIf + Nothing + True + (symNot "a") + (UnionSingle Nothing) + (UnionSingle (Just 2)) + ] + ], + testGroup + "ifWithStrategy on Single/If" + [ testGroup + "Degenerate to Single/Single when idxft == idxff" + [ testCase "Degenerated case with idxt < idxf" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle (Just (1 :: Integer))) + (UnionSingle (Just (2 :: Integer))) + ifWithStrategy rootStrategy "b" (UnionSingle Nothing) x + @?= UnionIf + Nothing + True + "b" + (UnionSingle Nothing) + ( UnionIf + (Just 1) + True + "a" + (UnionSingle $ Just 1) + (UnionSingle (Just 2)) + ), + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle (Just (1 :: Integer))) + (UnionSingle (Just (3 :: Integer))) + in testGroup + "Degenerated case with idxt == idxf" + [ testCase "sub-idxt < sub-idxft" $ + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ Just 0) + x + @?= UnionIf + (Just 0) + True + "b" + (UnionSingle $ Just 0) + ( UnionIf + (Just 1) + True + "a" + (UnionSingle $ Just 1) + (UnionSingle (Just 3)) + ), + testCase "sub-idxt == sub-idxft" $ + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ Just 1) + x + @?= UnionIf + (Just 1) + True + ("b" .|| "a") + (UnionSingle $ Just 1) + (UnionSingle (Just 3)), + testCase "subidxft < sub-idxt < sub-idxff" $ + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ Just 2) + x + @?= UnionIf + (Just 1) + True + ((symNot "b") .&& "a") + (UnionSingle $ Just 1) + ( UnionIf + (Just 2) + True + "b" + (UnionSingle $ Just 2) + (UnionSingle $ Just 3) + ), + testCase "sub-idxt == sub-idxff" $ + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ Just 3) + x + @?= UnionIf + (Just 1) + True + ((symNot "b") .&& "a") + (UnionSingle $ Just 1) + (UnionSingle (Just 3)), + testCase "sub-idxff < sub-idxt" $ + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ Just 4) + x + @?= UnionIf + (Just 1) + True + ((symNot "b") .&& "a") + (UnionSingle $ Just 1) + ( UnionIf + (Just 3) + True + (symNot "b") + (UnionSingle $ Just 3) + (UnionSingle $ Just 4) + ) + ], + testCase "Degenerated case with idxt > idxf" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle (Left (1 :: Integer))) + (UnionSingle (Left (2 :: Integer))) + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ Right (1 :: Integer)) + x + @?= UnionIf + (Left 1) + True + (symNot "b") + ( UnionIf + (Left 1) + True + "a" + (UnionSingle $ Left 1) + (UnionSingle (Left 2)) + ) + (UnionSingle $ Right 1) + ], + testCase "idxt < idxft" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle (1 :: Integer)) + (UnionSingle (3 :: Integer)) + ifWithStrategy rootStrategy "b" (UnionSingle 0) x + @?= UnionIf + 0 + True + "b" + (UnionSingle 0) + ( UnionIf + 1 + True + "a" + (UnionSingle 1) + (UnionSingle 3) + ), + testCase "idxt == idxft" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ Left (1 :: Integer)) + (UnionSingle $ Right (3 :: Integer)) + ifWithStrategy rootStrategy "b" (UnionSingle $ Left 0) x + @?= UnionIf + (Left 0) + True + ("b" .|| "a") + ( UnionIf + (Left 0) + True + "b" + (UnionSingle $ Left 0) + (UnionSingle $ Left 1) + ) + (UnionSingle $ Right 3), + testCase "idxt > idxft" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ Left (1 :: Integer)) + (UnionSingle $ Right (3 :: Integer)) + ifWithStrategy rootStrategy "b" (UnionSingle $ Right 0) x + @?= UnionIf + (Left 1) + True + ((symNot "b") .&& "a") + (UnionSingle $ Left 1) + ( UnionIf + (Right 0) + True + "b" + (UnionSingle $ Right 0) + (UnionSingle $ Right 3) + ) + ], + testGroup + "ifWithStrategy on If/Single" + [ testGroup + "Degenerate to Single/Single when idxtt == idxtf" + [ testCase "Degenerated case with idxt < idxf" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle (Left (1 :: Integer))) + (UnionSingle (Left (2 :: Integer))) + ifWithStrategy + rootStrategy + "b" + x + (UnionSingle $ Right (2 :: Integer)) + @?= UnionIf + (Left 1) + True + "b" + ( UnionIf + (Left 1) + True + "a" + (UnionSingle $ Left 1) + (UnionSingle (Left 2)) + ) + (UnionSingle $ Right 2), + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle (Just (1 :: Integer))) + (UnionSingle (Just (3 :: Integer))) + in testGroup + "Degenerated case with idxt == idxf" + [ testCase "sub-idxf < sub-idxtt" $ + ifWithStrategy + rootStrategy + "b" + x + (UnionSingle $ Just 0) + @?= UnionIf + (Just 0) + True + (symNot "b") + (UnionSingle $ Just 0) + ( UnionIf + (Just 1) + True + "a" + (UnionSingle $ Just 1) + (UnionSingle (Just 3)) + ), + testCase "sub-idxf == sub-idxtt" $ + ifWithStrategy + rootStrategy + "b" + x + (UnionSingle $ Just 1) + @?= UnionIf + (Just 1) + True + ((symNot "b") .|| "a") + (UnionSingle $ Just 1) + (UnionSingle (Just 3)), + testCase "sub-idxtt < sub-idxf < sub-idxtf" $ + ifWithStrategy + rootStrategy + "b" + x + (UnionSingle $ Just 2) + @?= UnionIf + (Just 1) + True + ("b" .&& "a") + (UnionSingle $ Just 1) + ( UnionIf + (Just 2) + True + (symNot "b") + (UnionSingle $ Just 2) + (UnionSingle $ Just 3) + ), + testCase "sub-idxf == sub-idxtf" $ + ifWithStrategy + rootStrategy + "b" + x + (UnionSingle $ Just 3) + @?= UnionIf + (Just 1) + True + ("b" .&& "a") + (UnionSingle $ Just 1) + (UnionSingle (Just 3)), + testCase "sub-idxtf < sub-idxf" $ + ifWithStrategy + rootStrategy + "b" + x + (UnionSingle $ Just 4) + @?= UnionIf + (Just 1) + True + ("b" .&& "a") + (UnionSingle $ Just 1) + ( UnionIf + (Just 3) + True + "b" + (UnionSingle $ Just 3) + (UnionSingle $ Just 4) + ) + ], + testCase "Degenerated case with idxt > idxf" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle (Right (1 :: Integer))) + (UnionSingle (Right (2 :: Integer))) + ifWithStrategy + rootStrategy + "b" + x + (UnionSingle $ Left (1 :: Integer)) + @?= UnionIf + (Left 1) + True + (symNot "b") + (UnionSingle $ Left 1) + ( UnionIf + (Right 1) + True + "a" + (UnionSingle $ Right 1) + (UnionSingle (Right 2)) + ) + ], + testCase "idxtt < idxf" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ Left (1 :: Integer)) + (UnionSingle $ Right (3 :: Integer)) + ifWithStrategy rootStrategy "b" x (UnionSingle $ Right 0) + @?= UnionIf + (Left 1) + True + ("b" .&& "a") + (UnionSingle $ Left 1) + ( UnionIf + (Right 0) + True + (symNot "b") + (UnionSingle $ Right 0) + (UnionSingle $ Right 3) + ), + testCase "idxtt == idxf" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ Left (1 :: Integer)) + (UnionSingle $ Right (3 :: Integer)) + ifWithStrategy rootStrategy "b" x (UnionSingle $ Left 0) + @?= UnionIf + (Left 0) + True + ((symNot "b") .|| "a") + ( UnionIf + (Left 0) + True + (symNot "b") + (UnionSingle $ Left 0) + (UnionSingle $ Left 1) + ) + (UnionSingle $ Right 3), + testCase "idxtt > idxf" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle (1 :: Integer)) + (UnionSingle (3 :: Integer)) + ifWithStrategy rootStrategy "b" x (UnionSingle 0) + @?= UnionIf + 0 + True + (symNot "b") + (UnionSingle 0) + (UnionIf 1 True "a" (UnionSingle 1) (UnionSingle 3)) + ], + testGroup + "ifWithStrategy on If/If" + [ testCase "Degenerate to Single/If when idxtt == idxtf" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ Left (1 :: Integer)) + (UnionSingle $ Left (2 :: Integer)) + let y = + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ Left (1 :: Integer)) + (UnionSingle $ Right (2 :: Integer)) + ifWithStrategy rootStrategy "c" x y + @?= UnionIf + (Left 1) + True + ("c" .|| "b") + ( UnionIf + (Left 1) + True + ((symNot "c") .|| "a") + (UnionSingle $ Left 1) + (UnionSingle $ Left 2) + ) + (UnionSingle $ Right 2), + testCase "Degenerate to Single/If when idxff == idxft" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ Left (1 :: Integer)) + (UnionSingle $ Left (2 :: Integer)) + let y = + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ Left (1 :: Integer)) + (UnionSingle $ Right (2 :: Integer)) + ifWithStrategy rootStrategy "c" y x + @?= UnionIf + (Left 1) + True + ((symNot "c") .|| "b") + ( UnionIf + (Left 1) + True + ("c" .|| "a") + (UnionSingle $ Left 1) + (UnionSingle $ Left 2) + ) + (UnionSingle $ Right 2), + testCase "Non-degenerated case when idxtt < idxft" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ TS1 (1 :: Integer)) + (UnionSingle $ TS2 (2 :: Integer)) + let y = + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ TS2 (1 :: Integer)) + (UnionSingle $ TS3 (2 :: Integer)) + ifWithStrategy rootStrategy "c" x y + @?= UnionIf + (TS1 1) + True + ("c" .&& "a") + (UnionSingle $ TS1 1) + ( UnionIf + (TS2 1) + True + ("c" .|| "b") + ( UnionIf + (TS2 1) + True + (symNot "c") + (UnionSingle $ TS2 1) + (UnionSingle $ TS2 2) + ) + (UnionSingle $ TS3 2) + ), + testCase "Non-degenerated case when idxtt == idxft" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ TS1 (1 :: Integer)) + (UnionSingle $ TS2 (2 :: Integer)) + let y = + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ TS1 (2 :: Integer)) + (UnionSingle $ TS3 (2 :: Integer)) + ifWithStrategy rootStrategy "c" x y + @?= UnionIf + (TS1 1) + True + (symIte "c" "a" "b") + ( UnionIf + (TS1 1) + True + "c" + (UnionSingle $ TS1 1) + (UnionSingle $ TS1 2) + ) + ( UnionIf + (TS2 2) + True + "c" + (UnionSingle $ TS2 2) + (UnionSingle $ TS3 2) + ), + testCase "Non-degenerated case when idxtt > idxft" $ do + let x = + ifWithStrategy + rootStrategy + "a" + (UnionSingle $ TS2 (1 :: Integer)) + (UnionSingle $ TS3 (2 :: Integer)) + let y = + ifWithStrategy + rootStrategy + "b" + (UnionSingle $ TS1 (1 :: Integer)) + (UnionSingle $ TS2 (2 :: Integer)) + ifWithStrategy rootStrategy "c" x y + @?= UnionIf + (TS1 1) + True + ((symNot "c") .&& "b") + (UnionSingle $ TS1 1) + ( UnionIf + (TS2 1) + True + ((symNot "c") .|| "a") + ( UnionIf + (TS2 1) + True + "c" + (UnionSingle $ TS2 1) + (UnionSingle $ TS2 2) + ) + (UnionSingle $ TS3 2) + ) + ], + testCase "ifWithStrategy should tolerate non-merged Ifs" $ do + let x = + UnionIf + (Right 2) + False + "a" + (UnionSingle $ Right (2 :: Integer)) + (UnionSingle $ Left (2 :: Integer)) + let y = + UnionIf + (Right 3) + False + "b" + (UnionSingle $ Right 3) + (UnionSingle $ Left 1) + ifWithStrategy rootStrategy "c" x y + @?= UnionIf + (Left 1) + True + (symIte "c" (symNot "a") (symNot "b")) + ( UnionIf + (Left 1) + True + (symNot "c") + (UnionSingle $ Left 1) + (UnionSingle $ Left 2) + ) + ( UnionIf + (Right 2) + True + "c" + (UnionSingle $ Right 2) + (UnionSingle $ Right 3) + ) + ] + ], + testGroup + "fullReconstruct" + [ testCase "fullReconstruct should work" $ do + let x = + UnionIf + (Right 2) + False + "a" + (UnionSingle $ Right (2 :: Integer)) + (UnionSingle $ Left (2 :: Integer)) + let y = + UnionIf + (Right 3) + False + "b" + (UnionSingle $ Right 3) + (UnionSingle $ Left 1) + let z = UnionIf (Right 2) False "c" x y + fullReconstruct rootStrategy z + @?= UnionIf + (Left 1) + True + (symIte "c" (symNot "a") (symNot "b")) + ( UnionIf + (Left 1) + True + (symNot "c") + (UnionSingle $ Left 1) + (UnionSingle $ Left 2) + ) + ( UnionIf + (Right 2) + True + "c" + (UnionSingle $ Right 2) + (UnionSingle $ Right 3) + ) + ] + ] diff --git a/test/Grisette/Core/TH/DerivationTest.hs b/test/Grisette/Core/TH/DerivationTest.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Core/TH/DerivationTest.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Core.TH.DerivationTest (concreteT, symbolicT) where + +import Data.Maybe (fromJust) +import Grisette + ( Default (Default), + SymInteger, + ToCon (toCon), + ToSym (toSym), + ) +import Grisette.TH (deriveAll) +import Grisette.Unified (EvalModeTag (Con, Sym), GetBool, GetData, GetWordN) + +data T mode n a + = T (GetBool mode) [GetWordN mode n] [a] (GetData mode (T mode n a)) + | TNil + +deriveAll ''T + +concreteT :: T 'Con 10 Integer +concreteT = toSym (T True [10] [10 :: Integer] TNil :: T 'Con 10 Integer) + +symbolicT :: T 'Sym 10 SymInteger +symbolicT = fromJust $ toCon (toSym concreteT :: T 'Sym 10 SymInteger) + +newtype X mode = X [GetBool mode] + +deriveAll ''X diff --git a/test/Grisette/Lib/Control/ApplicativeTest.hs b/test/Grisette/Lib/Control/ApplicativeTest.hs --- a/test/Grisette/Lib/Control/ApplicativeTest.hs +++ b/test/Grisette/Lib/Control/ApplicativeTest.hs @@ -13,8 +13,8 @@ ) import Control.Monad.Trans.Maybe (MaybeT (MaybeT)) import Grisette - ( UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + ( SymBranching (mrgIfPropagatedStrategy), + Union, mrgAsum, mrgEmpty, mrgPure, @@ -52,24 +52,24 @@ applicativeFunctionTests = testGroup "Applicative" - [ testCase "mrgPure" $ (mrgPure 1 :: UnionM Integer) @?= mrgSingle 1, + [ testCase "mrgPure" $ (mrgPure 1 :: Union Integer) @?= mrgSingle 1, testGroup ".<*>" [ testCase "merge result" $ do let actual = (return (\x -> x * x)) .<*> mrgIfPropagatedStrategy "a" (return $ -1) (return 1) - actual @?= (mrgSingle 1 :: UnionM Integer), + actual @?= (mrgSingle 1 :: Union Integer), testCase "merge arguments" $ do let actual = (return (const NoMerge)) .<*> oneNotMerged - actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + actual @?= (mrgSingle NoMerge :: Union NoMerge) ], testGroup "mrgLiftA2" [ testCase "merge result" $ do let actual = mrgLiftA2 (const $ const 1) noMergeNotMerged noMergeNotMerged - let expected = mrgPure 1 :: UnionM Int + let expected = mrgPure 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = @@ -92,16 +92,16 @@ return NoMerge .<* oneNotMerged @?= mrgSingle NoMerge ], testCase "mrgEmpty" $ - (mrgEmpty :: MaybeT UnionM Integer) @?= MaybeT (mrgReturn Nothing), + (mrgEmpty :: MaybeT Union Integer) @?= MaybeT (mrgReturn Nothing), testGroup ".<|>" [ testCase "merge result" $ - return 1 .<|> return 2 @?= (mrgSingle 1 :: MaybeT UnionM Integer), + return 1 .<|> return 2 @?= (mrgSingle 1 :: MaybeT Union Integer), testCase "merge lhs" $ do let lhs = MaybeT $ mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) - let expected = mrgSingle NoMerge :: MaybeT UnionM NoMerge + let expected = mrgSingle NoMerge :: MaybeT Union NoMerge lhs .<|> return NoMerge @?= expected ], plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ @@ -130,16 +130,16 @@ let actual = mrgIfPropagatedStrategy "a" (return $ -1) (return 1) .<**> (return (\x -> x * x)) - actual @?= (mrgSingle 1 :: UnionM Integer), + actual @?= (mrgSingle 1 :: Union Integer), testCase "merge arguments" $ do let actual = oneNotMerged .<**> (return (const NoMerge)) - actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + actual @?= (mrgSingle NoMerge :: Union NoMerge) ], testGroup "mrgLiftA" [ testCase "merge result" $ do let actual = mrgLiftA (const 1) noMergeNotMerged - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = mrgLiftA (const NoMerge) oneNotMerged @@ -155,7 +155,7 @@ noMergeNotMerged noMergeNotMerged noMergeNotMerged - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = @@ -178,7 +178,7 @@ (return $ Just 1) (return $ Just 1) ) - let expected = mrgSingle (Just 1) :: MaybeT UnionM (Maybe Int) + let expected = mrgSingle (Just 1) :: MaybeT Union (Maybe Int) actual @?= expected, testCase "none" $ do let actual = @@ -186,7 +186,7 @@ ( MaybeT $ mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) ) - let expected = mrgSingle Nothing :: MaybeT UnionM (Maybe Int) + let expected = mrgSingle Nothing :: MaybeT Union (Maybe Int) actual @?= expected ], plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ @@ -198,21 +198,21 @@ mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) let expected = MaybeT (mrgSingle Nothing) :: - MaybeT UnionM (Maybe Int) + MaybeT Union (Maybe Int) mrgAsum (replicate 100 none) @?= expected, testCase "semantics" $ do - (mrgAsum [mrgEmpty, mrgEmpty] :: MaybeT UnionM Integer) + (mrgAsum [mrgEmpty, mrgEmpty] :: MaybeT Union Integer) @?= mrgEmpty - (mrgAsum [mrgPure 1, mrgEmpty] :: MaybeT UnionM Integer) + (mrgAsum [mrgPure 1, mrgEmpty] :: MaybeT Union Integer) @?= mrgPure 1 - (mrgAsum [mrgEmpty, mrgPure 1] :: MaybeT UnionM Integer) + (mrgAsum [mrgEmpty, mrgPure 1] :: MaybeT Union Integer) @?= mrgPure 1 - (mrgAsum [mrgPure 2, mrgPure 1] :: MaybeT UnionM Integer) + (mrgAsum [mrgPure 2, mrgPure 1] :: MaybeT Union Integer) @?= mrgPure 2 ] ] -f :: StateT Int (MaybeT UnionM) () +f :: StateT Int (MaybeT Union) () f = do i <- get if (i == 0) diff --git a/test/Grisette/Lib/Control/Monad/ExceptTests.hs b/test/Grisette/Lib/Control/Monad/ExceptTests.hs --- a/test/Grisette/Lib/Control/Monad/ExceptTests.hs +++ b/test/Grisette/Lib/Control/Monad/ExceptTests.hs @@ -6,9 +6,9 @@ import Control.Monad.Trans.Except (ExceptT (ExceptT), runExceptT) import Grisette ( ITEOp (symIte), - SEq ((.==)), - UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + SymBranching (mrgIfPropagatedStrategy), + SymEq ((.==)), + Union, mrgIf, mrgSingle, ) @@ -27,7 +27,7 @@ import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) -exceptUnion :: ExceptT SymInteger UnionM SymInteger +exceptUnion :: ExceptT SymInteger Union SymInteger exceptUnion = mrgIfPropagatedStrategy "a" (throwError "b") (return "c") monadExceptFunctionTests :: Test @@ -35,16 +35,16 @@ testGroup "Except" [ testCase "mrgThrowError" $ - runExceptT (mrgThrowError 1 :: ExceptT Integer UnionM ()) + runExceptT (mrgThrowError 1 :: ExceptT Integer Union ()) @?= mrgSingle (Left 1), testCase "mrgCatchError" $ ( mrgIfPropagatedStrategy "a" (throwError "b") (return "c") :: - ExceptT SymBool UnionM SymBool + ExceptT SymBool Union SymBool ) `mrgCatchError` return @?= mrgSingle (symIte "a" "b" "c"), testCase "mrgLiftEither" $ do - runExceptT (mrgLiftEither (Left "a") :: ExceptT SymBool UnionM ()) + runExceptT (mrgLiftEither (Left "a") :: ExceptT SymBool Union ()) @?= mrgSingle (Left "a"), testCase "mrgTryError" $ do let expected = mrgIf "a" (mrgSingle (Left "b")) (mrgSingle (Right "c")) @@ -56,7 +56,7 @@ mrgHandleError return ( mrgIfPropagatedStrategy "a" (throwError "b") (return "c") :: - ExceptT SymBool UnionM SymBool + ExceptT SymBool Union SymBool ) @?= mrgSingle (symIte "a" "b" "c"), testCase "mrgMapError" $ do @@ -65,7 +65,7 @@ "a" (mrgThrowError (Just "b")) (mrgSingle $ ("c" :: SymInteger) .== 1) :: - ExceptT (Maybe SymInteger) UnionM SymBool + ExceptT (Maybe SymInteger) Union SymBool ) mrgMapError ( \m -> ExceptT $ do @@ -80,7 +80,7 @@ testCase "mrgModifyError" $ do let original = mrgIf "a" (mrgThrowError "b") (mrgSingle "c") :: - ExceptT SymInteger (ExceptT SymBool UnionM) SymInteger + ExceptT SymInteger (ExceptT SymBool Union) SymInteger let expected = mrgIf "a" diff --git a/test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs b/test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs --- a/test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs +++ b/test/Grisette/Lib/Control/Monad/Trans/ClassTests.hs @@ -8,8 +8,8 @@ import Control.Monad.Except (ExceptT) import Grisette ( ITEOp (symIte), - UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + SymBranching (mrgIfPropagatedStrategy), + Union, mrgSingle, ) import Grisette.Lib.Control.Monad.Trans (mrgLift) @@ -25,9 +25,9 @@ [ testCase "mrgLift" $ do ( mrgLift ( mrgIfPropagatedStrategy "a" (return "b") (return "c") :: - UnionM SymBool + Union SymBool ) :: - ExceptT SymBool UnionM SymBool + ExceptT SymBool Union SymBool ) @?= mrgSingle (symIte "a" "b" "c") ] diff --git a/test/Grisette/Lib/Control/Monad/Trans/ExceptTests.hs b/test/Grisette/Lib/Control/Monad/Trans/ExceptTests.hs --- a/test/Grisette/Lib/Control/Monad/Trans/ExceptTests.hs +++ b/test/Grisette/Lib/Control/Monad/Trans/ExceptTests.hs @@ -9,8 +9,8 @@ ) import Grisette ( ITEOp (symIte), - UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + SymBranching (mrgIfPropagatedStrategy), + Union, mrgIf, mrgSingle, ) @@ -26,19 +26,19 @@ import Test.Framework.Providers.HUnit (testCase) import Test.HUnit ((@?=)) -unmergedExceptT :: ExceptT SymInteger UnionM SymBool +unmergedExceptT :: ExceptT SymInteger Union SymBool unmergedExceptT = mrgIfPropagatedStrategy "e" (mrgIfPropagatedStrategy "c" (throwError "a") (throwError "b")) (return "d") -mergedExceptT :: ExceptT SymInteger UnionM SymBool +mergedExceptT :: ExceptT SymInteger Union SymBool mergedExceptT = ExceptT $ mrgIf "e" (mrgSingle (Left (symIte "c" "a" "b"))) (mrgSingle (Right "d")) -mergedExceptTPlus1 :: ExceptT SymInteger UnionM SymBool +mergedExceptTPlus1 :: ExceptT SymInteger Union SymBool mergedExceptTPlus1 = ExceptT $ mrgIf "e" (mrgSingle (Left (symIte "c" "a" "b" + 1))) (mrgSingle (Right "d")) @@ -48,7 +48,7 @@ testGroup "Except" [ testCase "mrgExcept" $ do - let actual = mrgExcept (Left "a") :: ExceptT SymInteger UnionM SymBool + let actual = mrgExcept (Left "a") :: ExceptT SymInteger Union SymBool let expected = ExceptT (mrgSingle (Left "a")) actual @?= expected, testCase "mrgRunExceptT" $ do @@ -56,7 +56,7 @@ testCase "mrgWithExceptT" $ do mrgWithExceptT (+ 1) unmergedExceptT @?= mergedExceptTPlus1, testCase "mrgThrowE" $ do - let actual = mrgThrowE "a" :: ExceptT SymInteger UnionM SymBool + let actual = mrgThrowE "a" :: ExceptT SymInteger Union SymBool actual @?= ExceptT (mrgSingle (Left "a")), testCase "mrgCatchE" $ do let actual = mrgCatchE unmergedExceptT (throwError . (+ 1)) diff --git a/test/Grisette/Lib/Control/Monad/Trans/State/Common.hs b/test/Grisette/Lib/Control/Monad/Trans/State/Common.hs --- a/test/Grisette/Lib/Control/Monad/Trans/State/Common.hs +++ b/test/Grisette/Lib/Control/Monad/Trans/State/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} module Grisette.Lib.Control.Monad.Trans.State.Common @@ -19,8 +20,8 @@ MonadUnion, SimpleMergeable (mrgIte), SymBool, - UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + SymBranching (mrgIfPropagatedStrategy), + Union, mrgSingle, unionSize, ) @@ -30,56 +31,56 @@ import Grisette.TestUtil.SymbolicAssertion ((@?=~)) import Test.HUnit (Assertion, (@?=)) -type StateConstructor stateT s a = (s -> UnionM (a, s)) -> stateT s UnionM a +type StateConstructor stateT s a = (s -> Union (a, s)) -> stateT s Union a -type StateFunc stateT s a = (s -> (a, s)) -> stateT s UnionM a +type StateFunc stateT s a = (s -> (a, s)) -> stateT s Union a -type RunStateFunc stateT s a = stateT s UnionM a -> s -> UnionM (a, s) +type RunStateFunc stateT s a = stateT s Union a -> s -> Union (a, s) -type EvalStateFunc stateT s a = stateT s UnionM a -> s -> UnionM a +type EvalStateFunc stateT s a = stateT s Union a -> s -> Union a -type ExecStateFunc stateT s a = stateT s UnionM a -> s -> UnionM s +type ExecStateFunc stateT s a = stateT s Union a -> s -> Union s type MapStateFunc stateT s a = - (UnionM (a, s) -> UnionM (a, s)) -> - stateT s UnionM a -> - stateT s UnionM a + (Union (a, s) -> Union (a, s)) -> + stateT s Union a -> + stateT s Union a type WithStateFunc stateT s a = (s -> s) -> - stateT s UnionM a -> - stateT s UnionM a + stateT s Union a -> + stateT s Union a -type GetFunc stateT s a = stateT s UnionM s +type GetFunc stateT s a = stateT s Union s -type PutFunc stateT s a = s -> stateT s UnionM () +type PutFunc stateT s a = s -> stateT s Union () -type ModifyFunc stateT s a = (s -> s) -> stateT s UnionM () +type ModifyFunc stateT s a = (s -> s) -> stateT s Union () -type GetsFunc stateT s a = (s -> a) -> stateT s UnionM a +type GetsFunc stateT s a = (s -> a) -> stateT s Union a -bodyA :: SymBool -> UnionM (SymBool, SymBool) +bodyA :: SymBool -> Union (SymBool, SymBool) bodyA s = return (s .&& ssymBool "av", s .&& ssymBool "as") stateA :: - StateConstructor stateT SymBool SymBool -> stateT SymBool UnionM SymBool + StateConstructor stateT SymBool SymBool -> stateT SymBool Union SymBool stateA state = state bodyA -bodyB :: SymBool -> UnionM (SymBool, SymBool) +bodyB :: SymBool -> Union (SymBool, SymBool) bodyB s = return (s .&& ssymBool "bv", s .&& ssymBool "bs") stateB :: - StateConstructor stateT SymBool SymBool -> stateT SymBool UnionM SymBool + StateConstructor stateT SymBool SymBool -> stateT SymBool Union SymBool stateB state = state bodyB stateAB :: - (UnionMergeable1 (stateT SymBool UnionM)) => + (SymBranching (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> - stateT SymBool UnionM SymBool + stateT SymBool Union SymBool stateAB state = mrgIfPropagatedStrategy (ssymBool "c") (state bodyA) (state bodyB) mrgStateTest :: - (MonadUnion (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union)) => StateFunc stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> Assertion @@ -88,7 +89,8 @@ mrgState (\s -> (s .&& ssymBool "av", s .&& ssymBool "as")) let b = mrgState (\s -> (s .&& ssymBool "bv", s .&& ssymBool "bs")) - let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") + let actual = + runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") let expected = mrgSingle ( mrgIte @@ -104,7 +106,7 @@ actual @?=~ expected mrgRunStateTTest :: - (MonadUnion (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> Assertion @@ -125,7 +127,7 @@ actual @?=~ expected mrgEvalStateTTest :: - (MonadUnion (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> EvalStateFunc stateT SymBool SymBool -> Assertion @@ -142,7 +144,7 @@ actual @?=~ expected mrgExecStateTTest :: - (MonadUnion (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> ExecStateFunc stateT SymBool SymBool -> Assertion @@ -159,7 +161,7 @@ actual @?=~ expected mrgMapStateTTest :: - (MonadUnion (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> MapStateFunc stateT SymBool SymBool -> @@ -183,7 +185,7 @@ actual @?=~ expected mrgWithStateTTest :: - (MonadUnion (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> WithStateFunc stateT SymBool SymBool -> @@ -207,7 +209,7 @@ actual @?=~ expected mrgGetTest :: - (MonadUnion (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union), Monad (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> GetFunc stateT SymBool SymBool -> @@ -231,7 +233,7 @@ actual @?=~ expected mrgPutTest :: - (MonadUnion (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union), Monad (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool () -> PutFunc stateT SymBool SymBool -> @@ -248,7 +250,7 @@ actual @?=~ expected mrgModifyTest :: - (MonadUnion (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union), Monad (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool () -> ModifyFunc stateT SymBool SymBool -> @@ -272,7 +274,7 @@ actual @?=~ expected mrgGetsTest :: - (MonadUnion (stateT SymBool UnionM), Monad (stateT SymBool UnionM)) => + (MonadUnion (stateT SymBool Union), Monad (stateT SymBool Union)) => StateConstructor stateT SymBool SymBool -> RunStateFunc stateT SymBool SymBool -> GetsFunc stateT SymBool SymBool -> @@ -280,7 +282,8 @@ mrgGetsTest state runStateT mrgGets = do let a = do stateA state; mrgGets (.&& ssymBool "x") let b = do stateB state; mrgGets (.&& ssymBool "y") - let actual = runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") + let actual = + runStateT (mrgIfPropagatedStrategy (ssymBool "c") a b) (ssymBool "d") let expected = mrgSingle ( mrgIte diff --git a/test/Grisette/Lib/Control/MonadTests.hs b/test/Grisette/Lib/Control/MonadTests.hs --- a/test/Grisette/Lib/Control/MonadTests.hs +++ b/test/Grisette/Lib/Control/MonadTests.hs @@ -14,12 +14,12 @@ import Grisette ( ITEOp (symIte), LogicalOp ((.&&), (.||)), - SEq ((./=), (.==)), - SOrd ((.<=)), Solvable (con), + SymBranching (mrgIfPropagatedStrategy), + SymEq ((./=), (.==)), SymInteger, - UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + SymOrd ((.<=)), + Union, mrgFilterM, mrgGuard, mrgIf, @@ -84,56 +84,56 @@ monadFunctionTests = testGroup "Monad" - [ testCase "mrgReturn" $ (mrgReturn 1 :: UnionM Integer) @?= mrgSingle 1, + [ testCase "mrgReturn" $ (mrgReturn 1 :: Union Integer) @?= mrgSingle 1, testGroup ".>>=" [ testCase "merge result" $ do let actual = mrgIfPropagatedStrategy "a" (return $ -1) (return 1) .>>= (\x -> return $ x * x) - actual @?= (mrgSingle 1 :: UnionM Integer), + actual @?= (mrgSingle 1 :: Union Integer), testCase "merge argument" $ do let actual = mrgIfPropagatedStrategy "a" (return (1 :: Int)) (return 1) .>>= const (return NoMerge) - actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + actual @?= (mrgSingle NoMerge :: Union NoMerge) ], testGroup ".>>" [ testCase "merge result" $ do let actual = ( mrgIfPropagatedStrategy "a" (return $ -1) (return 1) :: - UnionM Integer + Union Integer ) .>> mrgIfPropagatedStrategy "a" (return $ -1) (return 1) let expected = mrgIf "a" (mrgReturn $ -1) (mrgReturn 1) :: - UnionM Integer + Union Integer actual @?= expected, testCase "merge lhs" $ do let actual = ( mrgIfPropagatedStrategy "a" (return 1) (return 1) :: - UnionM Integer + Union Integer ) .>> return NoMerge - let expected = mrgReturn NoMerge :: UnionM NoMerge + let expected = mrgReturn NoMerge :: Union NoMerge actual @?= expected ], testCase "mrgFail" $ do - let actual = mrgFail "a" :: MaybeT UnionM Int + let actual = mrgFail "a" :: MaybeT Union Int actual @?= MaybeT (mrgSingle Nothing), testCase "mrgMzero" $ do - (mrgMzero :: MaybeT UnionM Integer) @?= MaybeT (mrgReturn Nothing), + (mrgMzero :: MaybeT Union Integer) @?= MaybeT (mrgReturn Nothing), testGroup "mrgMplus" [ testCase "merge result" $ do - let actual = (mzero `mrgMplus` return 1 :: MaybeT UnionM Integer) + let actual = (mzero `mrgMplus` return 1 :: MaybeT Union Integer) actual @?= mrgReturn 1, testCase "merge lhs" $ do let lhs = MaybeT $ mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) :: - MaybeT UnionM NoMerge + MaybeT Union NoMerge let rhs = return NoMerge lhs `mrgMplus` rhs @?= MaybeT (mrgReturn $ Just NoMerge) ], @@ -143,12 +143,12 @@ let actual = (\x -> return $ x * x) .=<< mrgIfPropagatedStrategy "a" (return $ -1) (return 1) - actual @?= (mrgSingle 1 :: UnionM Integer), + actual @?= (mrgSingle 1 :: Union Integer), testCase "merge argument" $ do let actual = const (return NoMerge) .=<< mrgIfPropagatedStrategy "a" (return (1 :: Int)) (return 1) - actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + actual @?= (mrgSingle NoMerge :: Union NoMerge) ], testGroup ".>=>" @@ -159,10 +159,10 @@ "a" (return $ -1) (return 1) :: - UnionM Integer + Union Integer ) let actual = lhs .>=> (\x -> return $ x * x) - actual (0 :: Integer) @?= (mrgSingle 1 :: UnionM Integer), + actual (0 :: Integer) @?= (mrgSingle 1 :: Union Integer), testCase "merge lhs result" $ do let lhs = const @@ -170,7 +170,7 @@ "a" (return 1) (return 1) :: - UnionM Integer + Union Integer ) let actual = lhs .>=> const (return NoMerge) actual (0 :: Integer) @?= mrgSingle NoMerge @@ -184,10 +184,10 @@ "a" (return $ -1) (return 1) :: - UnionM Integer + Union Integer ) let actual = (\x -> return $ x * x) .<=< rhs - actual (0 :: Integer) @?= (mrgSingle 1 :: UnionM Integer), + actual (0 :: Integer) @?= (mrgSingle 1 :: Union Integer), testCase "merge rhs result" $ do let rhs = const @@ -195,28 +195,28 @@ "a" (return 1) (return 1) :: - UnionM Integer + Union Integer ) let actual = const (return NoMerge) .<=< rhs actual (0 :: Integer) @?= mrgSingle NoMerge ], testCase "mrgForever" $ do - let f :: StateT Int (ExceptT NoMerge UnionM) () + let f :: StateT Int (ExceptT NoMerge Union) () f = do i <- get when (i == 0) $ throwError NoMerge put (i - 1) lift . lift $ mrgIfPropagatedStrategy "a" (return ()) (return ()) - let actual = mrgForever f :: StateT Int (ExceptT NoMerge UnionM) NoMerge + let actual = mrgForever f :: StateT Int (ExceptT NoMerge Union) NoMerge runStateT actual 10 @?= ExceptT (mrgReturn $ Left NoMerge), testCase "mrgJoin" $ - mrgJoin (return $ return 1) @?= (mrgSingle 1 :: UnionM Integer), + mrgJoin (return $ return 1) @?= (mrgSingle 1 :: Union Integer), testCase "mrgMfilter" $ do - let actual = mrgMfilter (const True) (return 1 :: MaybeT UnionM Int) + let actual = mrgMfilter (const True) (return 1 :: MaybeT Union Int) actual @?= (mrgSingle 1), testCase "symMfilter" $ do - let actual = symMfilter (.== 0) (return "a" :: MaybeT UnionM SymInteger) + let actual = symMfilter (.== 0) (return "a" :: MaybeT Union SymInteger) let expected = mrgIf ("a" .== (0 :: SymInteger)) (mrgReturn "a") mrgMzero actual @?= expected, @@ -224,21 +224,21 @@ "mrgFilterM" [ testCase "merge result" $ do let actual = mrgFilterM (return . odd) [1, 2, 3, 4] - let expected = mrgReturn [1, 3] :: UnionM [Int] + let expected = mrgReturn [1, 3] :: Union [Int] actual @?= expected, testCase "merge argument" $ do let actual = mrgFilterM (const $ mrgIfPropagatedStrategy "a" (return True) (return True)) [NoMerge, NoMerge] - let expected = mrgReturn [NoMerge, NoMerge] :: UnionM [NoMerge] + let expected = mrgReturn [NoMerge, NoMerge] :: Union [NoMerge] actual @?= expected ], testGroup "symFilterM" [ testCase "merge result" $ do let actual = symFilterM (return . con . odd) [1, 2, 3, 4] - let expected = mrgReturn [1, 3] :: UnionM [Int] + let expected = mrgReturn [1, 3] :: Union [Int] actual @?= expected, testCase "merge argument" $ do let actual = @@ -250,7 +250,7 @@ (return $ con True) ) [NoMerge, NoMerge] - let expected = mrgReturn [NoMerge, NoMerge] :: UnionM [NoMerge] + let expected = mrgReturn [NoMerge, NoMerge] :: Union [NoMerge] actual @?= expected, testCase "symbolic semantics" $ do let a = "a" :: SymInteger @@ -262,7 +262,7 @@ (a .== 0 .|| b .== 0) (return [symIte (a .== 0) b a]) (return [a, b]) :: - UnionM [SymInteger] + Union [SymInteger] actual @?= expected actual .@?= expected ], @@ -277,7 +277,7 @@ (return (x, x + 1)) ) [1 .. 100] :: - UnionM ([Int], [Int]) + Union ([Int], [Int]) let expected = mrgReturn ([1 .. 100], [2 .. 101]) actual @?= expected, plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ @@ -292,7 +292,7 @@ ) [1 .. 100] [1 .. 100] :: - UnionM ([Int]) + Union ([Int]) let expected = mrgReturn ((* 2) <$> [1 .. 100]) actual @?= expected, plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ @@ -307,7 +307,7 @@ ) [1 .. 100 :: Int] [1 .. 100] :: - UnionM () + Union () let expected = mrgReturn () actual @?= expected, plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ @@ -322,7 +322,7 @@ ) 10 [1 .. 100] :: - UnionM Integer + Union Integer actual @?= mrgReturn 5060, plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ testCase "mrgFoldM_" $ do @@ -336,7 +336,7 @@ ) 10 [1 .. 100 :: Int] :: - UnionM () + Union () actual @?= mrgReturn (), plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ testCase "mrgReplicateM" $ do @@ -344,7 +344,7 @@ mrgReplicateM 100 (mrgIfPropagatedStrategy "a" (return 1) (return 1)) :: - UnionM [Int] + Union [Int] actual @?= mrgReturn [1 | _ <- [1 .. 100]], plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ testGroup @@ -355,7 +355,7 @@ 200 (100 :: SymInteger) (mrgIfPropagatedStrategy "a" (return 1) (return 1)) :: - UnionM [Int] + Union [Int] actual @?= mrgReturn [1 | _ <- [1 .. 100]], testCase "symbolic semantics" $ do let a = "a" :: SymInteger @@ -364,18 +364,18 @@ 2 a (mrgIfPropagatedStrategy "a" (return 1) (return 1)) :: - UnionM [Int] + Union [Int] let expected = mrgIf (a .<= 0) (return []) (mrgIf (a .== 1) (return [1]) (return [1, 1])) :: - UnionM [Int] + Union [Int] actual .@?= expected ], plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ testCase "mrgReplicateM_" $ do - let actual = mrgReplicateM_ 100 noMergeNotMerged :: UnionM () + let actual = mrgReplicateM_ 100 noMergeNotMerged :: Union () actual @?= mrgReturn (), plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ testGroup @@ -383,43 +383,43 @@ [ testCase "merge result and intermediate" $ do let actual = symReplicateM_ 200 (100 :: SymInteger) noMergeNotMerged :: - UnionM () + Union () actual @?= mrgReturn () ], testCase "mrgGuard" $ do - mrgGuard True @?= (mrgReturn () :: MaybeT UnionM ()) - mrgGuard False @?= (MaybeT $ mrgReturn Nothing :: MaybeT UnionM ()), + mrgGuard True @?= (mrgReturn () :: MaybeT Union ()) + mrgGuard False @?= (MaybeT $ mrgReturn Nothing :: MaybeT Union ()), testCase "symGuard" $ do let expected = MaybeT $ mrgIf "a" (return $ Just ()) (return Nothing) :: - MaybeT UnionM () + MaybeT Union () symGuard "a" @?= expected, testCase "mrgWhen" $ do mrgWhen True (throwError "a") - @?= (mrgThrowError "a" :: ExceptT String UnionM ()) + @?= (mrgThrowError "a" :: ExceptT String Union ()) mrgWhen False (throwError "a") - @?= (mrgReturn () :: ExceptT String UnionM ()), + @?= (mrgReturn () :: ExceptT String Union ()), testCase "symWhen" $ do let expected = mrgIf "a" (mrgThrowError "x") (return ()) :: - ExceptT String UnionM () + ExceptT String Union () symWhen "a" (throwError "x") @?= expected, testCase "mrgUnless" $ do mrgUnless False (throwError "a") - @?= (mrgThrowError "a" :: ExceptT String UnionM ()) + @?= (mrgThrowError "a" :: ExceptT String Union ()) mrgUnless True (throwError "a") - @?= (mrgReturn () :: ExceptT String UnionM ()), + @?= (mrgReturn () :: ExceptT String Union ()), testCase "symUnless" $ do let expected = mrgIf "a" (return ()) (mrgThrowError "x") :: - ExceptT String UnionM () + ExceptT String Union () symUnless "a" (throwError "x") @?= expected, testGroup "mrgLiftM" [ testCase "merge result" $ do let actual = mrgLiftM (const 1) noMergeNotMerged - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = mrgLiftM (const NoMerge) oneNotMerged @@ -431,7 +431,7 @@ [ testCase "merge result" $ do let actual = mrgLiftM2 (const $ const 1) noMergeNotMerged noMergeNotMerged - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = @@ -448,7 +448,7 @@ noMergeNotMerged noMergeNotMerged noMergeNotMerged - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = @@ -470,7 +470,7 @@ noMergeNotMerged noMergeNotMerged noMergeNotMerged - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = @@ -494,7 +494,7 @@ noMergeNotMerged noMergeNotMerged noMergeNotMerged - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = @@ -512,7 +512,7 @@ "mrgAp" [ testCase "merge result" $ do let actual = mrgAp (return $ const 1) noMergeNotMerged - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = mrgAp (return $ const NoMerge) oneNotMerged @@ -523,7 +523,7 @@ ".<$!>" [ testCase "merge result" $ do let actual = const 1 .<$!> noMergeNotMerged - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected, testCase "merge argument" $ do let actual = const NoMerge .<$!> oneNotMerged diff --git a/test/Grisette/Lib/Data/FoldableTests.hs b/test/Grisette/Lib/Data/FoldableTests.hs --- a/test/Grisette/Lib/Data/FoldableTests.hs +++ b/test/Grisette/Lib/Data/FoldableTests.hs @@ -11,12 +11,12 @@ import Grisette ( ITEOp (symIte), LogicalOp ((.&&), (.||)), - SEq ((./=), (.==)), - SOrd (symCompare, (.<=), (.>)), SymBool, + SymBranching (mrgIfPropagatedStrategy), + SymEq ((./=), (.==)), SymInteger, - UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + SymOrd (symCompare, (.<=), (.>)), + Union, mrgIf, symAll, symAny, @@ -73,7 +73,7 @@ (a .> b .&& a .> c) (return [a]) (mrgIf (b .> c) (return [b, a]) (return [c, a, b])) :: - UnionM [SymInteger] + Union [SymInteger] actual .@?= expected, testCase "symMaximum" $ do let [a, b, c] = ["a", "b", "c"] :: [SymInteger] @@ -88,7 +88,7 @@ (a .<= b .&& a .<= c) (return [a]) (mrgIf (b .<= c) (return [b, a]) (return [c, a, b])) :: - UnionM [SymInteger] + Union [SymInteger] actual .@?= expected, testCase "symMinimum" $ do let [a, b, c] = ["a", "b", "c"] :: [SymInteger] @@ -109,7 +109,7 @@ ) 10 [("a", 2), ("b", 3)] :: - UnionM Integer + Union Integer let expected = mrgIf "b" @@ -118,7 +118,7 @@ actual @?= expected, testCase "merge intermediate" $ do let actual = mrgFoldrM (const $ const oneNotMerged) 1 [1 .. 1000] - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected ], plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ @@ -135,7 +135,7 @@ ) 10 [("a", 2), ("b", 3)] :: - UnionM Integer + Union Integer let expected = mrgIf "a" @@ -144,7 +144,7 @@ actual @?= expected, testCase "merge intermediate" $ do let actual = mrgFoldlM (const $ const oneNotMerged) 1 [1 .. 1000] - let expected = mrgReturn 1 :: UnionM Int + let expected = mrgReturn 1 :: Union Int actual @?= expected ], plusTestOptions (mempty {topt_timeout = Just (Just 1000000)}) $ @@ -169,7 +169,7 @@ (return $ Right c) ) [("a", 3), ("b", 2)] :: - ExceptT Integer UnionM () + ExceptT Integer Union () ) let expected = runExceptT $ do _ <- mrgIf "a" (throwError 3) (return ()) @@ -178,7 +178,7 @@ actual @?= expected, testCase "discard and merge intermediate" $ do let actual = func1 (const noMergeNotMerged) [1 .. 1000] - let expected = mrgReturn () :: UnionM () + let expected = mrgReturn () :: Union () actual @?= expected ] ], @@ -202,7 +202,7 @@ (return $ Right c) ) <$> [("a", 3), ("b", 2)] :: - ExceptT Integer UnionM () + ExceptT Integer Union () ) let expected = runExceptT $ do _ <- mrgIf "a" (throwError 3) (return ()) @@ -211,7 +211,7 @@ actual @?= expected, testCase "discard and merge intermediate" $ do let actual = func1 (replicate 1000 noMergeNotMerged) - let expected = mrgReturn () :: UnionM () + let expected = mrgReturn () :: Union () actual @?= expected ] ], @@ -224,16 +224,16 @@ mrgIfPropagatedStrategy "a" (return Nothing) (return Nothing) let expected = MaybeT (mrgReturn Nothing) :: - MaybeT UnionM (Maybe Int) + MaybeT Union (Maybe Int) mrgMsum (replicate 100 none) @?= expected, testCase "semantics" $ do - (mrgMsum [mrgMzero, mrgMzero] :: MaybeT UnionM Integer) + (mrgMsum [mrgMzero, mrgMzero] :: MaybeT Union Integer) @?= mrgMzero - (mrgMsum [mrgReturn 1, mrgMzero] :: MaybeT UnionM Integer) + (mrgMsum [mrgReturn 1, mrgMzero] :: MaybeT Union Integer) @?= mrgReturn 1 - (mrgMsum [mrgMzero, mrgReturn 1] :: MaybeT UnionM Integer) + (mrgMsum [mrgMzero, mrgReturn 1] :: MaybeT Union Integer) @?= mrgReturn 1 - (mrgMsum [mrgReturn 2, mrgReturn 1] :: MaybeT UnionM Integer) + (mrgMsum [mrgReturn 2, mrgReturn 1] :: MaybeT Union Integer) @?= mrgReturn 2 ], testCase "symAnd" $ do @@ -256,7 +256,7 @@ (a .> b .&& a .> c) (return [a]) (mrgIf (b .> c) (return [b, a]) (return [c, a, b])) :: - UnionM [SymInteger] + Union [SymInteger] actual .@?= expected, testCase "symMaximumBy" $ do let [a, b, c] = ["a", "b", "c"] :: [SymInteger] @@ -271,7 +271,7 @@ (a .<= b .&& a .<= c) (return [a]) (mrgIf (b .<= c) (return [b, a]) (return [c, a, b])) :: - UnionM [SymInteger] + Union [SymInteger] actual .@?= expected, testCase "symMinimumBy" $ do let [a, b, c] = ["a", "b", "c"] :: [SymInteger] @@ -284,7 +284,7 @@ actual .@?= (a ./= b .&& a ./= c), testCase "mrgFind" $ do let [a, b, c] = ["a", "b", "c"] :: [SymInteger] - let actual = mrgFind (.== 0) [a, b, c] :: UnionM (Maybe SymInteger) + let actual = mrgFind (.== 0) [a, b, c] :: Union (Maybe SymInteger) actual .@?= mrgIf (a .== 0) diff --git a/test/Grisette/Lib/Data/FunctorTests.hs b/test/Grisette/Lib/Data/FunctorTests.hs --- a/test/Grisette/Lib/Data/FunctorTests.hs +++ b/test/Grisette/Lib/Data/FunctorTests.hs @@ -4,9 +4,9 @@ import Grisette ( ITEOp (symIte), + SymBranching (mrgIfPropagatedStrategy), SymInteger, - UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + Union, mrgIf, mrgSingle, mrgVoid, @@ -38,10 +38,10 @@ let actual = mrgFmap (\x -> x * x) $ mrgIfPropagatedStrategy "a" (return $ -1) (return 1) - actual @?= (mrgSingle 1 :: UnionM Integer), + actual @?= (mrgSingle 1 :: Union Integer), testCase "merge arguments" $ do let actual = mrgFmap (const NoMerge) oneNotMerged - actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + actual @?= (mrgSingle NoMerge :: Union NoMerge) ], testGroup ".<$>" @@ -49,24 +49,24 @@ let actual = (\x -> x * x) .<$> mrgIfPropagatedStrategy "a" (return $ -1) (return 1) - actual @?= (mrgSingle 1 :: UnionM Integer), + actual @?= (mrgSingle 1 :: Union Integer), testCase "merge arguments" $ do let actual = (const NoMerge) .<$> oneNotMerged - actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + actual @?= (mrgSingle NoMerge :: Union NoMerge) ], testGroup ".<$" [ testCase "merge result" $ - 1 .<$ noMergeNotMerged @?= (mrgSingle 1 :: UnionM Integer), + 1 .<$ noMergeNotMerged @?= (mrgSingle 1 :: Union Integer), testCase "merge arguments" $ - NoMerge .<$ oneNotMerged @?= (mrgSingle NoMerge :: UnionM NoMerge) + NoMerge .<$ oneNotMerged @?= (mrgSingle NoMerge :: Union NoMerge) ], testGroup ".$>" [ testCase "merge result" $ - noMergeNotMerged .$> 1 @?= (mrgSingle 1 :: UnionM Integer), + noMergeNotMerged .$> 1 @?= (mrgSingle 1 :: Union Integer), testCase "merge arguments" $ - oneNotMerged .$> NoMerge @?= (mrgSingle NoMerge :: UnionM NoMerge) + oneNotMerged .$> NoMerge @?= (mrgSingle NoMerge :: Union NoMerge) ], testGroup ".<&>" @@ -74,10 +74,10 @@ let actual = mrgIfPropagatedStrategy "a" (return $ -1) (return 1) .<&> (\x -> x * x) - actual @?= (mrgSingle 1 :: UnionM Integer), + actual @?= (mrgSingle 1 :: Union Integer), testCase "merge arguments" $ do let actual = oneNotMerged .<&> (const NoMerge) - actual @?= (mrgSingle NoMerge :: UnionM NoMerge) + actual @?= (mrgSingle NoMerge :: Union NoMerge) ], testCase "mrgUnzip" $ do let actual = @@ -87,10 +87,10 @@ ( mrgSingle (symIte "x" "a" "b"), mrgIf "x" 1 2 ) :: - (UnionM SymInteger, UnionM Integer) + (Union SymInteger, Union Integer) actual @?= expected, testCase "mrgVoid" $ do let actual = mrgVoid noMergeNotMerged - let expected = mrgSingle () :: UnionM () + let expected = mrgSingle () :: Union () actual @?= expected ] diff --git a/test/Grisette/Lib/Data/ListTests.hs b/test/Grisette/Lib/Data/ListTests.hs --- a/test/Grisette/Lib/Data/ListTests.hs +++ b/test/Grisette/Lib/Data/ListTests.hs @@ -42,11 +42,11 @@ import Grisette ( ITEOp (symIte), LogicalOp (symNot, (.&&), (.||)), - SEq ((./=), (.==)), - SOrd (symCompare, (.<=), (.>=)), Solvable (con), SymBool, - UnionM, + SymEq ((./=), (.==)), + SymOrd (symCompare, (.<=), (.>=)), + Union, mrgGroupBy, mrgIf, ) @@ -116,11 +116,11 @@ "mrgTake" [ testProperty "concrete int" $ \(n :: Integer) -> forAll ranilist $ \ranilist -> ioProperty $ do - let actual = mrgTake n ranilist :: UnionM [SymInteger] + let actual = mrgTake n ranilist :: Union [SymInteger] let expected = mrgPure $ take (fromInteger n) ranilist actual @?= expected, testCase "symbolic int" $ do - let actual = mrgTake aint [bint, cint, dint] :: UnionM [SymInteger] + let actual = mrgTake aint [bint, cint, dint] :: Union [SymInteger] let expected = mrgIf (aint .<= 0) (return []) $ mrgIf (aint .== 1) (return [bint]) $ @@ -132,11 +132,11 @@ "mrgDrop" [ testProperty "concrete int" $ \(n :: Integer) -> forAll ranilist $ \ranilist -> ioProperty $ do - let actual = mrgDrop n ranilist :: UnionM [SymInteger] + let actual = mrgDrop n ranilist :: Union [SymInteger] let expected = mrgPure $ drop (fromInteger n) ranilist actual @?= expected, testCase "symbolic int" $ do - let actual = mrgDrop aint [bint, cint, dint] :: UnionM [SymInteger] + let actual = mrgDrop aint [bint, cint, dint] :: Union [SymInteger] let expected = mrgIf (aint .>= 3) (return []) $ mrgIf (aint .== 2) (return [dint]) $ @@ -150,13 +150,13 @@ \(n :: Integer) -> forAll ranilist $ \ranilist -> ioProperty $ do let actual = mrgSplitAt n ranilist :: - UnionM ([SymInteger], [SymInteger]) + Union ([SymInteger], [SymInteger]) let expected = mrgPure $ splitAt (fromInteger n) ranilist actual @?= expected, testCase "symbolic int" $ do let actual = mrgSplitAt aint [bint, cint, dint] :: - UnionM ([SymInteger], [SymInteger]) + Union ([SymInteger], [SymInteger]) let expected = mrgIf (aint .<= 0) (return ([], [bint, cint, dint])) $ mrgIf (aint .== 1) (return ([bint], [cint, dint])) $ @@ -168,12 +168,12 @@ "mrgTakeWhile" [ testProperty "concrete int" $ \ranilist -> ioProperty $ do - let actual = mrgTakeWhile (.== 0) ranilist :: UnionM [Integer] + let actual = mrgTakeWhile (.== 0) ranilist :: Union [Integer] let expected = mrgPure $ takeWhile (== 0) ranilist actual @?= expected, testCase "symbolic int" $ do let actual = - mrgTakeWhile (.== 0) [aint, bint, cint] :: UnionM [SymInteger] + mrgTakeWhile (.== 0) [aint, bint, cint] :: Union [SymInteger] let expected = mrgIf (aint ./= 0) (return []) $ mrgIf (bint ./= 0) (return [aint]) $ @@ -185,12 +185,12 @@ "mrgDropWhile" [ testProperty "concrete int" $ \ranilist -> ioProperty $ do - let actual = mrgDropWhile (.== 0) ranilist :: UnionM [Integer] + let actual = mrgDropWhile (.== 0) ranilist :: Union [Integer] let expected = mrgPure $ dropWhile (== 0) ranilist actual @?= expected, testCase "symbolic int" $ do let actual = - mrgDropWhile (.== 0) [aint, bint, cint] :: UnionM [SymInteger] + mrgDropWhile (.== 0) [aint, bint, cint] :: Union [SymInteger] let expected = mrgIf ((aint .== 0 .&& bint .== 0) .&& cint .== 0) @@ -204,13 +204,13 @@ "mrgDropWhileEnd" [ testProperty "concrete int" $ \ranilist -> ioProperty $ do - let actual = mrgDropWhileEnd (.== 0) ranilist :: UnionM [Integer] + let actual = mrgDropWhileEnd (.== 0) ranilist :: Union [Integer] let expected = mrgPure $ dropWhileEnd (== 0) ranilist actual @?= expected, testCase "symbolic int" $ do let actual = mrgDropWhileEnd (.== 0) [aint, bint, cint] :: - UnionM [SymInteger] + Union [SymInteger] let expected = mrgIf ((cint .== 0 .&& bint .== 0) .&& aint .== 0) @@ -225,13 +225,13 @@ [ testProperty "concrete int" $ \ranilist -> ioProperty $ do let actual = - mrgSpan (.== 0) ranilist :: UnionM ([Integer], [Integer]) + mrgSpan (.== 0) ranilist :: Union ([Integer], [Integer]) let expected = mrgPure $ span (== 0) ranilist actual @?= expected, testCase "symbolic int" $ do let actual = mrgSpan (.== 0) [aint, bint, cint] :: - UnionM ([SymInteger], [SymInteger]) + Union ([SymInteger], [SymInteger]) let expected = mrgIf (aint ./= 0) (return ([], [aint, bint, cint])) $ mrgIf (bint ./= 0) (return ([aint], [bint, cint])) $ @@ -244,13 +244,13 @@ [ testProperty "concrete int" $ \ranilist -> ioProperty $ do let actual = - mrgBreak (.== 0) ranilist :: UnionM ([Integer], [Integer]) + mrgBreak (.== 0) ranilist :: Union ([Integer], [Integer]) let expected = mrgPure $ break (== 0) ranilist actual @?= expected, testCase "symbolic int" $ do let actual = mrgBreak (.== 0) [aint, bint, cint] :: - UnionM ([SymInteger], [SymInteger]) + Union ([SymInteger], [SymInteger]) let expected = mrgIf (aint .== 0) (return ([], [aint, bint, cint])) $ mrgIf (bint .== 0) (return ([aint], [bint, cint])) $ @@ -262,13 +262,13 @@ "mrgStripPrefix" [ testProperty "concrete int" $ \l1 l2 -> ioProperty $ do - let actual = mrgStripPrefix l1 l2 :: UnionM (Maybe [Integer]) + let actual = mrgStripPrefix l1 l2 :: Union (Maybe [Integer]) let expected = mrgPure $ stripPrefix l1 l2 actual @?= expected, testCase "symbolic int" $ do let actual = mrgStripPrefix [aint, bint] [cint, dint, eint] :: - UnionM (Maybe [SymInteger]) + Union (Maybe [SymInteger]) let expected = mrgIf (symNot ((aint .== cint) .&& (bint .== dint))) @@ -280,11 +280,11 @@ "mrgGroup" [ testProperty "concrete int" $ \l -> ioProperty $ do - let actual = mrgGroup l :: UnionM [[Integer]] + let actual = mrgGroup l :: Union [[Integer]] let expected = mrgPure $ group l actual @?= expected, testCase "symbolic int" $ do - let actual = mrgGroup [aint, bint, cint] :: UnionM [[SymInteger]] + let actual = mrgGroup [aint, bint, cint] :: Union [[SymInteger]] let expected = mrgIf (aint .== bint .&& aint .== cint) @@ -339,7 +339,7 @@ @?= ( (aint .== cint .&& bint .== dint) .|| (aint .== dint .&& bint .== eint) ) - .|| (aint .== eint .&& bint .== fint), + .|| (aint .== eint .&& bint .== fint), testCase "symbolic int, not long enough" $ do let actual = symIsInfixOf [cint, dint, eint] [aint, bint] actual @?= con False @@ -371,7 +371,7 @@ "mrgLookup" [ testProperty "concrete int" $ \v l -> ioProperty $ do - let actual = mrgLookup (v :: Integer) l :: UnionM (Maybe Integer) + let actual = mrgLookup (v :: Integer) l :: Union (Maybe Integer) let expected = mrgPure $ lookup v l actual @?= expected, testCase "symbolic int" $ do @@ -382,7 +382,7 @@ (dint, Nothing), (fint, Just eint) ] :: - UnionM (Maybe (Maybe SymInteger)) + Union (Maybe (Maybe SymInteger)) let expected = mrgIf ((aint ./= bint .&& aint ./= dint) .&& aint ./= fint) @@ -398,12 +398,12 @@ "mrgFilter" [ testProperty "concrete int" $ \l -> ioProperty $ do - let actual = mrgFilter (.== 0) l :: UnionM [Integer] + let actual = mrgFilter (.== 0) l :: Union [Integer] let expected = mrgPure $ filter (== 0) l actual @?= expected, testCase "symbolic int" $ do let actual = - mrgFilter (.== 0) [aint, bint] :: UnionM [SymInteger] + mrgFilter (.== 0) [aint, bint] :: Union [SymInteger] let expected = mrgIf (symNot $ aint .== 0 .|| bint .== 0) (return []) $ mrgIf @@ -418,13 +418,13 @@ \l -> ioProperty $ do let actual = mrgPartition (.== 0) l :: - UnionM ([Integer], [Integer]) + Union ([Integer], [Integer]) let expected = mrgPure $ partition (== 0) l actual @?= expected, testCase "symbolic int" $ do let actual = mrgPartition (.== 0) [aint, bint] :: - UnionM ([SymInteger], [SymInteger]) + Union ([SymInteger], [SymInteger]) let expected = mrgIf (symNot $ aint .== 0 .|| bint .== 0) @@ -443,14 +443,14 @@ ".!?" [ testProperty "concrete int" $ \l (i :: Int) -> ioProperty $ do - let actual = l .!? i :: UnionM (Maybe Integer) + let actual = l .!? i :: Union (Maybe Integer) let expected = mrgPure $ if i < 0 || i >= length l then Nothing else Just $ l !! i actual @?= expected, testCase "symbolic int" $ do let actual = - [aint, bint, cint] .!? dint :: UnionM (Maybe SymInteger) + [aint, bint, cint] .!? dint :: Union (Maybe SymInteger) let expected = mrgIf (symNot (dint .== 0 .|| dint .== 1 .|| dint .== 2)) @@ -466,13 +466,13 @@ "mrgElemIndex" [ testProperty "concrete int" $ \(v :: Integer) l -> ioProperty $ do - let actual = mrgElemIndex v l :: UnionM (Maybe Int) + let actual = mrgElemIndex v l :: Union (Maybe Int) let expected = mrgPure $ elemIndex v l actual @?= expected, testCase "symbolic int" $ do let actual = mrgElemIndex aint [bint, cint, dint] :: - UnionM (Maybe SymInteger) + Union (Maybe SymInteger) let expected = mrgIf (symNot $ aint .== bint .|| aint .== cint .|| aint .== dint) @@ -487,7 +487,7 @@ "mrgElemIndices" [ testProperty "concrete int" $ \(v :: Integer) l -> ioProperty $ do - let actual = mrgElemIndices v l :: UnionM [Int] + let actual = mrgElemIndices v l :: Union [Int] let expected = mrgPure $ elemIndices v l actual @?= expected ], @@ -495,13 +495,13 @@ "mrgFindIndex" [ testProperty "concrete int" $ \(l :: [Integer]) -> ioProperty $ do - let actual = mrgFindIndex (.== 0) l :: UnionM (Maybe Int) + let actual = mrgFindIndex (.== 0) l :: Union (Maybe Int) let expected = mrgPure $ findIndex (== 0) l actual @?= expected, testCase "symbolic int" $ do let actual = mrgFindIndex (.== 0) [aint, bint, cint] :: - UnionM (Maybe SymInteger) + Union (Maybe SymInteger) let expected = mrgIf (symNot $ aint .== 0 .|| bint .== 0 .|| cint .== 0) @@ -516,7 +516,7 @@ "mrgFindIndices" [ testProperty "concrete int" $ \(l :: [Integer]) -> ioProperty $ do - let actual = mrgFindIndices (.== 0) l :: UnionM [Int] + let actual = mrgFindIndices (.== 0) l :: Union [Int] let expected = mrgPure $ findIndices (== 0) l actual @?= expected ], @@ -524,11 +524,11 @@ "mrgNub" [ testProperty "concrete int" $ \l -> ioProperty $ do - let actual = mrgNub l :: UnionM [Integer] + let actual = mrgNub l :: Union [Integer] let expected = mrgPure $ nub l actual @?= expected, testCase "symbolic int" $ do - let actual = mrgNub [aint, bint, cint] :: UnionM [SymInteger] + let actual = mrgNub [aint, bint, cint] :: Union [SymInteger] let expected = mrgIf (bint .== aint .&& cint .== aint) @@ -543,12 +543,12 @@ "mrgDelete" [ testProperty "concrete int" $ \i l -> ioProperty $ do - let actual = mrgDelete i l :: UnionM [Integer] + let actual = mrgDelete i l :: Union [Integer] let expected = mrgPure $ delete i l actual @?= expected, testCase "symbolic int" $ do let actual = - mrgDelete aint [bint, cint, dint] :: UnionM [SymInteger] + mrgDelete aint [bint, cint, dint] :: Union [SymInteger] let expected = mrgIf (aint .== bint .|| aint .== cint .|| aint .== dint) @@ -564,7 +564,7 @@ ".\\\\" [ testProperty "concrete int" $ \l1 l2 -> ioProperty $ do - let actual = l1 .\\ l2 :: UnionM [Integer] + let actual = l1 .\\ l2 :: Union [Integer] let expected = mrgPure $ l1 \\ l2 actual @?= expected ], @@ -572,7 +572,7 @@ "mrgUnion" [ testProperty "concrete int" $ \l1 l2 -> ioProperty $ do - let actual = mrgUnion l1 l2 :: UnionM [Integer] + let actual = mrgUnion l1 l2 :: Union [Integer] let expected = mrgPure $ union l1 l2 actual @?= expected ], @@ -580,12 +580,12 @@ "mrgIntersect" [ testProperty "concrete int" $ \l1 l2 -> ioProperty $ do - let actual = mrgIntersect l1 l2 :: UnionM [Integer] + let actual = mrgIntersect l1 l2 :: Union [Integer] let expected = mrgPure $ intersect l1 l2 actual @?= expected, testCase "symbolic int" $ do let actual = - mrgIntersect [aint, bint] [cint, dint] :: UnionM [SymInteger] + mrgIntersect [aint, bint] [cint, dint] :: Union [SymInteger] let expected = mrgIf ( symNot $ @@ -609,12 +609,12 @@ "mrgNubBy" [ testProperty "concrete int" $ \l -> ioProperty $ do - let actual = mrgNubBy (.==) l :: UnionM [Integer] + let actual = mrgNubBy (.==) l :: Union [Integer] let expected = mrgPure $ nubBy (==) l actual @?= expected, testCase "symbolic int" $ do let actual = - mrgNubBy (.==) [aint, bint, cint] :: UnionM [SymInteger] + mrgNubBy (.==) [aint, bint, cint] :: Union [SymInteger] let expected = mrgIf (bint .== aint .&& cint .== aint) @@ -629,13 +629,13 @@ "mrgDeleteBy" [ testProperty "concrete int" $ \i l -> ioProperty $ do - let actual = mrgDeleteBy (./=) i l :: UnionM [Integer] + let actual = mrgDeleteBy (./=) i l :: Union [Integer] let expected = mrgPure $ deleteBy (/=) i l actual @?= expected, testCase "symbolic int" $ do let actual = mrgDeleteBy (./=) aint [bint, cint, dint] :: - UnionM [SymInteger] + Union [SymInteger] let expected = mrgIf ( symNot $ @@ -653,7 +653,7 @@ "mrgDeleteFirstsBy" [ testProperty "concrete int" $ \l1 l2 -> ioProperty $ do - let actual = mrgDeleteFirstsBy (./=) l1 l2 :: UnionM [Integer] + let actual = mrgDeleteFirstsBy (./=) l1 l2 :: Union [Integer] let expected = mrgPure $ deleteFirstsBy (/=) l1 l2 actual @?= expected ], @@ -661,7 +661,7 @@ "mrgUnionBy" [ testProperty "concrete int" $ \l1 l2 -> ioProperty $ do - let actual = mrgUnionBy (.==) l1 l2 :: UnionM [Integer] + let actual = mrgUnionBy (.==) l1 l2 :: Union [Integer] let expected = mrgPure $ unionBy (==) l1 l2 actual @?= expected ], @@ -669,13 +669,13 @@ "mrgIntersectBy" [ testProperty "concrete int" $ \l1 l2 -> ioProperty $ do - let actual = mrgIntersectBy (.==) l1 l2 :: UnionM [Integer] + let actual = mrgIntersectBy (.==) l1 l2 :: Union [Integer] let expected = mrgPure $ intersectBy (==) l1 l2 actual @?= expected, testCase "symbolic int" $ do let actual = mrgIntersectBy (.==) [aint, bint] [cint, dint] :: - UnionM [SymInteger] + Union [SymInteger] let expected = mrgIf ( symNot $ @@ -699,12 +699,12 @@ "mrgGroupBy" [ testProperty "concrete int" $ \l -> ioProperty $ do - let actual = mrgGroupBy (.==) l :: UnionM [[Integer]] + let actual = mrgGroupBy (.==) l :: Union [[Integer]] let expected = mrgPure $ groupBy (==) l actual @?= expected, testCase "symbolic int" $ do let actual = - mrgGroupBy (.==) [aint, bint, cint] :: UnionM [[SymInteger]] + mrgGroupBy (.==) [aint, bint, cint] :: Union [[SymInteger]] let expected = mrgIf (aint .== bint .&& aint .== cint) @@ -722,12 +722,12 @@ "mrgInsert" [ testProperty "concrete int" $ \i l -> ioProperty $ do - let actual = mrgInsert i l :: UnionM [Integer] + let actual = mrgInsert i l :: Union [Integer] let expected = mrgPure $ insert i l actual @?= expected, testCase "symbolic int" $ do let actual = - mrgInsert aint [bint, cint, dint] :: UnionM [SymInteger] + mrgInsert aint [bint, cint, dint] :: Union [SymInteger] let expected = mrgPure [ symIte (aint .<= bint) aint bint, @@ -746,7 +746,7 @@ "mrgInsertBy" [ testProperty "concrete int" $ \i l -> ioProperty $ do - let actual = mrgInsertBy symCompare i l :: UnionM [Integer] + let actual = mrgInsertBy symCompare i l :: Union [Integer] let expected = mrgPure $ insertBy compare i l actual @?= expected ] diff --git a/test/Grisette/Lib/Data/TraversableTests.hs b/test/Grisette/Lib/Data/TraversableTests.hs --- a/test/Grisette/Lib/Data/TraversableTests.hs +++ b/test/Grisette/Lib/Data/TraversableTests.hs @@ -7,8 +7,8 @@ MonadError (throwError), ) import Grisette - ( UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + ( SymBranching (mrgIfPropagatedStrategy), + Union, mrgIf, mrgSingle, ) @@ -63,7 +63,7 @@ ) ) [("a", "c", 3, 4, 5), ("b", "d", 2, 3, 6)] :: - ExceptT Integer UnionM [Integer] + ExceptT Integer Union [Integer] let expected = do a <- mrgIf @@ -113,7 +113,7 @@ (return $ Right 6) ) ] :: - ExceptT Integer UnionM [Integer] + ExceptT Integer Union [Integer] let expected = do a <- mrgIf @@ -152,7 +152,7 @@ ( 500500, [(i - 1) * i `div` 2 - i | i <- [1 .. 1000]] ) :: - UnionM (Integer, [Integer]) + Union (Integer, [Integer]) actual @?= expected, testCase "merge intermediate" $ do let actual = @@ -167,7 +167,7 @@ [1 .. 1000] let expected = mrgReturn (1, replicate 1000 1) :: - UnionM (Integer, [Integer]) + Union (Integer, [Integer]) actual @?= expected ] ] diff --git a/test/Grisette/SymPrim/SomeBVTests.hs b/test/Grisette/SymPrim/SomeBVTests.hs --- a/test/Grisette/SymPrim/SomeBVTests.hs +++ b/test/Grisette/SymPrim/SomeBVTests.hs @@ -22,16 +22,19 @@ ITEOp (symIte), LogicalOp (symNot), Mergeable (rootStrategy), - SEq ((./=), (.==)), SafeLinearArith (safeAdd, safeSub), Solvable (con, isym, ssym), + SymEq ((./=), (.==)), genSym, genSymSimple, mrgIf, mrgSingle, ) -import Grisette.Internal.Core.Control.Monad.UnionM (UnionM (UMrg)) -import Grisette.Internal.Core.Data.Union (Union (UnionSingle), ifWithLeftMost) +import Grisette.Internal.Core.Control.Monad.Union (Union (UMrg)) +import Grisette.Internal.Core.Data.UnionBase + ( UnionBase (UnionSingle), + ifWithLeftMost, + ) import Grisette.Internal.SymPrim.BV (BitwidthMismatch (BitwidthMismatch), IntN) import Grisette.Internal.SymPrim.SomeBV ( SomeBV (SomeBV), @@ -92,7 +95,7 @@ (Eq r, Show r, Mergeable r) => ( SomeIntN -> SomeIntN -> - ExceptT (Either BitwidthMismatch ArithException) UnionM r + ExceptT (Either BitwidthMismatch ArithException) Union r ) -> SomeIntN -> SomeIntN -> @@ -107,7 +110,7 @@ (Eq r, Show r, Mergeable r) => ( SomeIntN -> SomeIntN -> - ExceptT (Either BitwidthMismatch ArithException) UnionM r + ExceptT (Either BitwidthMismatch ArithException) Union r ) -> SomeIntN -> SomeIntN -> @@ -122,7 +125,7 @@ (Eq r, Show r, Mergeable r) => ( SomeIntN -> SomeIntN -> - ExceptT (Either BitwidthMismatch ArithException) UnionM r + ExceptT (Either BitwidthMismatch ArithException) Union r ) -> SomeIntN -> SomeIntN -> @@ -313,7 +316,7 @@ ] return $ testCase name $ do let actual = - mrgIf "cond" (return l) (return r) :: UnionM SomeIntN + mrgIf "cond" (return l) (return r) :: Union SomeIntN let expected = UMrg rootStrategy merged actual @?= expected, testGroup "SomeSymIntN" $ do @@ -344,24 +347,24 @@ ] return $ testCase name $ do let actual = - mrgIf "cond" (return l) (return r) :: UnionM SomeSymIntN + mrgIf "cond" (return l) (return r) :: Union SomeSymIntN let expected = UMrg rootStrategy merged actual @?= expected ], testGroup "GenSym" [ testCase "Proxy n" $ do - let actual = genSym (Proxy :: Proxy 4) "a" :: UnionM SomeSymIntN + let actual = genSym (Proxy :: Proxy 4) "a" :: Union SomeSymIntN let expected = mrgSingle $ isymBV 4 "a" 0 actual @?= expected, testCase "SomeBV" $ do let actual = - genSym (bv 4 1 :: SomeSymIntN) "a" :: UnionM SomeSymIntN + genSym (bv 4 1 :: SomeSymIntN) "a" :: Union SomeSymIntN let expected = mrgSingle $ isymBV 4 "a" 0 actual @?= expected, testCase "Int" $ do let actual = - genSym (4 :: Int) "a" :: UnionM SomeSymIntN + genSym (4 :: Int) "a" :: Union SomeSymIntN let expected = mrgSingle $ isymBV 4 "a" 0 actual @?= expected ], @@ -411,7 +414,7 @@ assertBool "SomeBV with different bit width are not equal" $ a /= b ], testGroup - "SEq" + "SymEq" [ testCase "same bitwidth" $ do let a = ssymBV 4 "a" :: SomeSymIntN let b = ssymBV 4 "b" :: SomeSymIntN diff --git a/test/Grisette/SymPrim/SymPrimTests.hs b/test/Grisette/SymPrim/SymPrimTests.hs --- a/test/Grisette/SymPrim/SymPrimTests.hs +++ b/test/Grisette/SymPrim/SymPrimTests.hs @@ -40,8 +40,8 @@ import Grisette ( Apply (apply), BV (bv), - EvaluateSym (evaluateSym), - ExtractSymbolics (extractSymbolics), + EvalSym (evalSym), + ExtractSym (extractSym), Function ((#)), ITEOp (symIte), LogicalOp (symImplies, symNot, symXor, (.&&), (.||)), @@ -49,8 +49,6 @@ MergingStrategy (SimpleStrategy), ModelOps (emptyModel, insertValue), ModelRep (buildModel), - SEq ((./=), (.==)), - SOrd (symCompare, (.<), (.<=), (.>), (.>=)), SafeDivision ( safeDiv, safeDivMod, @@ -75,10 +73,12 @@ Solvable (con, conView, isym, ssym), SomeSymIntN, SomeSymWordN, + SymEq ((./=), (.==)), + SymOrd (symCompare, (.<), (.<=), (.>), (.>=)), ToCon (toCon), ToSym (toSym), TypedSymbol, - UnionM, + Union, genSym, genSymSimple, mrgIf, @@ -189,7 +189,7 @@ ) => c -> c -> - (s -> s -> ExceptT ArithException UnionM s) -> + (s -> s -> ExceptT ArithException Union s) -> (c -> c -> c) -> Assertion sameSafeDiv i j f cf = do @@ -210,7 +210,7 @@ ) => c -> c -> - (s -> s -> ExceptT ArithException UnionM (s, s)) -> + (s -> s -> ExceptT ArithException Union (s, s)) -> (c -> c -> (c, c)) -> Assertion sameSafeDivMod i j f cf = do @@ -221,8 +221,8 @@ safeDivisionBoundedOnlyTests :: forall c s. - (LinkedRep c s, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - (s -> s -> ExceptT ArithException UnionM s) -> + (LinkedRep c s, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => + (s -> s -> ExceptT ArithException Union s) -> (c -> c -> c) -> (Term c -> Term c -> Term c) -> [Test] @@ -239,14 +239,14 @@ (throwError Overflow) (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) ) :: - ExceptT ArithException UnionM s + ExceptT ArithException Union s ) ] safeDivisionUnboundedOnlyTests :: forall c s. - (LinkedRep c s, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => - (s -> s -> ExceptT ArithException UnionM s) -> + (LinkedRep c s, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => + (s -> s -> ExceptT ArithException Union s) -> (Term c -> Term c -> Term c) -> [Test] safeDivisionUnboundedOnlyTests f pf = @@ -256,15 +256,15 @@ ((ssym "b" :: s) .== con (0 :: c) :: SymBool) (throwError DivideByZero) (mrgSingle $ wrapTerm $ pf (ssymTerm "a") (ssymTerm "b")) :: - ExceptT ArithException UnionM s + ExceptT ArithException Union s ) ] safeDivisionGeneralTests :: forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => (c0 -> c) -> - (s -> s -> ExceptT ArithException UnionM s) -> + (s -> s -> ExceptT ArithException Union s) -> (c -> c -> c) -> [Test] safeDivisionGeneralTests transform f cf = @@ -279,15 +279,15 @@ sameSafeDiv i 0 f cf, testCase "when divided by zero" $ do f (ssym "a" :: s) (con 0) - @=? (tryMerge $ throwError DivideByZero :: ExceptT ArithException UnionM s) + @=? (tryMerge $ throwError DivideByZero :: ExceptT ArithException Union s) ] safeDivisionBoundedTests :: forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (LinkedRep c s, Arbitrary c0, Show c0, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => TestName -> (c0 -> c) -> - (s -> s -> ExceptT ArithException UnionM s) -> + (s -> s -> ExceptT ArithException Union s) -> (c -> c -> c) -> (Term c -> Term c -> Term c) -> Test @@ -298,10 +298,10 @@ safeDivisionUnboundedTests :: forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => TestName -> (c0 -> c) -> - (s -> s -> ExceptT ArithException UnionM s) -> + (s -> s -> ExceptT ArithException Union s) -> (c -> c -> c) -> (Term c -> Term c -> Term c) -> Test @@ -312,10 +312,10 @@ safeDivModBoundedOnlyTests :: forall c s. - (LinkedRep c s, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (LinkedRep c s, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => ( s -> s -> - ExceptT ArithException UnionM (s, s) + ExceptT ArithException Union (s, s) ) -> (c -> c -> (c, c)) -> (Term c -> Term c -> Term c) -> @@ -338,16 +338,16 @@ ) ) ) :: - ExceptT ArithException UnionM (s, s) + ExceptT ArithException Union (s, s) ) ] safeDivModUnboundedOnlyTests :: forall c s. - (LinkedRep c s, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (LinkedRep c s, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => ( s -> s -> - ExceptT ArithException UnionM (s, s) + ExceptT ArithException Union (s, s) ) -> (Term c -> Term c -> Term c) -> (Term c -> Term c -> Term c) -> @@ -363,17 +363,17 @@ wrapTerm $ pf2 (ssymTerm "a") (ssymTerm "b") ) ) :: - ExceptT ArithException UnionM (s, s) + ExceptT ArithException Union (s, s) ) ] safeDivModGeneralTests :: forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => (c0 -> c) -> ( s -> s -> - ExceptT ArithException UnionM (s, s) + ExceptT ArithException Union (s, s) ) -> (c -> c -> (c, c)) -> [Test] @@ -389,17 +389,17 @@ sameSafeDivMod i 0 f cf, testCase "when divided by zero" $ do f (ssym "a" :: s) (con 0) - @=? (tryMerge $ throwError DivideByZero :: ExceptT ArithException UnionM (s, s)) + @=? (tryMerge $ throwError DivideByZero :: ExceptT ArithException Union (s, s)) ] safeDivModBoundedTests :: forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (LinkedRep c s, Arbitrary c0, Show c0, Bounded c, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => TestName -> (c0 -> c) -> ( s -> s -> - ExceptT ArithException UnionM (s, s) + ExceptT ArithException Union (s, s) ) -> (c -> c -> (c, c)) -> (Term c -> Term c -> Term c) -> @@ -412,12 +412,12 @@ safeDivModUnboundedTests :: forall c c0 s. - (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SEq s) => + (LinkedRep c s, Arbitrary c0, Show c0, Solvable c s, Eq s, Num c, Show s, Mergeable s, SymEq s) => TestName -> (c0 -> c) -> ( s -> s -> - ExceptT ArithException UnionM (s, s) + ExceptT ArithException Union (s, s) ) -> (c -> c -> (c, c)) -> (Term c -> Term c -> Term c) -> @@ -473,15 +473,15 @@ [ testCase "To self" $ toCon (ssym "a" :: SymBool) @=? (Nothing :: Maybe Bool), testCase "To concrete" $ toCon True @=? Just True ], - testCase "EvaluateSym" $ do + testCase "EvalSym" $ do let m1 = emptyModel :: Model let m2 = insertValue "a" (1 :: Integer) m1 let m3 = insertValue "b" True m2 - evaluateSym False m3 (symIte ("c" :: SymBool) "a" ("a" + "a" :: SymInteger)) + evalSym False m3 (symIte ("c" :: SymBool) "a" ("a" + "a" :: SymInteger)) @=? symIte ("c" :: SymBool) 1 2 - evaluateSym True m3 (symIte ("c" :: SymBool) "a" ("a" + "a" :: SymInteger)) @=? 2, - testCase "ExtractSymbolics" $ - extractSymbolics (symIte ("c" :: SymBool) ("a" :: SymInteger) ("b" :: SymInteger)) + evalSym True m3 (symIte ("c" :: SymBool) "a" ("a" + "a" :: SymInteger)) @=? 2, + testCase "ExtractSym" $ + extractSym (symIte ("c" :: SymBool) ("a" :: SymInteger) ("b" :: SymInteger)) @=? SymbolSet ( S.fromList [ someTypedSymbol ("c" :: TypedSymbol Bool), @@ -490,11 +490,11 @@ ] ), testCase "GenSym" $ do - (genSym () "a" :: UnionM SymBool) @=? mrgSingle (isym "a" 0) + (genSym () "a" :: Union SymBool) @=? mrgSingle (isym "a" 0) (genSymSimple () "a" :: SymBool) @=? isym "a" 0 - (genSym (ssym "a" :: SymBool) "a" :: UnionM SymBool) @=? mrgSingle (isym "a" 0) + (genSym (ssym "a" :: SymBool) "a" :: Union SymBool) @=? mrgSingle (isym "a" 0) (genSymSimple (ssym "a" :: SymBool) "a" :: SymBool) @=? isym "a" 0, - testCase "SEq" $ do + testCase "SymEq" $ do (ssym "a" :: SymBool) .== ssym "b" @=? SymBool (pevalEqTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b")) (ssym "a" :: SymBool) ./= ssym "b" @=? SymBool (pevalNotTerm $ pevalEqTerm (ssymTerm "a" :: Term Bool) (ssymTerm "b")) ], @@ -535,36 +535,36 @@ [ testProperty "safeAdd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do safeAdd (con i :: SymInteger) (con j) - @=? (mrgSingle $ con $ i + j :: ExceptT ArithException UnionM SymInteger), + @=? (mrgSingle $ con $ i + j :: ExceptT ArithException Union SymInteger), testCase "safeAdd on symbolic" $ do safeAdd (ssym "a" :: SymInteger) (ssym "b") - @=? (mrgSingle $ SymInteger $ pevalAddNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException UnionM SymInteger), + @=? (mrgSingle $ SymInteger $ pevalAddNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException Union SymInteger), testProperty "safeNeg on concrete" $ \(i :: Integer) -> ioProperty $ do safeNeg (con i :: SymInteger) - @=? (mrgSingle $ con $ -i :: ExceptT ArithException UnionM SymInteger), + @=? (mrgSingle $ con $ -i :: ExceptT ArithException Union SymInteger), testCase "safeNeg on symbolic" $ do safeNeg (ssym "a" :: SymInteger) - @=? (mrgSingle $ SymInteger $ pevalNegNumTerm (ssymTerm "a") :: ExceptT ArithException UnionM SymInteger), + @=? (mrgSingle $ SymInteger $ pevalNegNumTerm (ssymTerm "a") :: ExceptT ArithException Union SymInteger), testProperty "safeSub on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do safeSub (con i :: SymInteger) (con j) - @=? (mrgSingle $ con $ i - j :: ExceptT ArithException UnionM SymInteger), + @=? (mrgSingle $ con $ i - j :: ExceptT ArithException Union SymInteger), testCase "safeSub on symbolic" $ do safeSub (ssym "a" :: SymInteger) (ssym "b") - @=? (mrgSingle $ SymInteger $ pevalSubNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException UnionM SymInteger) + @=? (mrgSingle $ SymInteger $ pevalSubNumTerm (ssymTerm "a") (ssymTerm "b") :: ExceptT ArithException Union SymInteger) ], testGroup - "SOrd" - [ testProperty "SOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do + "SymOrd" + [ testProperty "SymOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do (con i :: SymInteger) .<= con j @=? (con (i <= j) :: SymBool) (con i :: SymInteger) .< con j @=? (con (i < j) :: SymBool) (con i :: SymInteger) .>= con j @=? (con (i >= j) :: SymBool) (con i :: SymInteger) .> con j @=? (con (i > j) :: SymBool) (con i :: SymInteger) `symCompare` con j - @=? (i `symCompare` j :: UnionM Ordering), - testCase "SOrd on symbolic" $ do + @=? (i `symCompare` j :: Union Ordering), + testCase "SymOrd on symbolic" $ do let a :: SymInteger = ssym "a" let b :: SymInteger = ssym "b" let at :: Term Integer = ssymTerm "a" @@ -573,7 +573,7 @@ a .< b @=? SymBool (pevalLtOrdTerm at bt) a .>= b @=? SymBool (pevalGeOrdTerm at bt) a .> b @=? SymBool (pevalGtOrdTerm at bt) - (a `symCompare` ssym "b" :: UnionM Ordering) + (a `symCompare` ssym "b" :: Union Ordering) @=? mrgIf (a .< b) (mrgSingle LT) (mrgIf (a .== b) (mrgSingle EQ) (mrgSingle GT)) ] ], @@ -647,7 +647,7 @@ ( mrgIf (iint + jint .> fromIntegral (i + j)) (throwError Overflow) - (mrgSingle $ toSym $ i + j :: ExceptT ArithException UnionM (SymIntN 8)) + (mrgSingle $ toSym $ i + j :: ExceptT ArithException Union (SymIntN 8)) ), testProperty "safeSub on concrete" $ \(i :: Int8, j :: Int8) -> ioProperty $ @@ -660,7 +660,7 @@ ( mrgIf (iint - jint .> fromIntegral (i - j)) (throwError Overflow) - (mrgSingle $ toSym $ i - j :: ExceptT ArithException UnionM (SymIntN 8)) + (mrgSingle $ toSym $ i - j :: ExceptT ArithException Union (SymIntN 8)) ), testProperty "safeNeg on concrete" $ \(i :: Int8) -> ioProperty $ @@ -672,7 +672,7 @@ ( mrgIf (-iint .> fromIntegral (-i)) (throwError Overflow) - (mrgSingle $ toSym $ -i :: ExceptT ArithException UnionM (SymIntN 8)) + (mrgSingle $ toSym $ -i :: ExceptT ArithException Union (SymIntN 8)) ) ], testGroup @@ -688,7 +688,7 @@ ( mrgIf (iint + jint .> fromIntegral (i + j)) (throwError Overflow) - (mrgSingle $ toSym $ i + j :: ExceptT ArithException UnionM (SymWordN 8)) + (mrgSingle $ toSym $ i + j :: ExceptT ArithException Union (SymWordN 8)) ), testProperty "safeSub on concrete" $ \(i :: Word8, j :: Word8) -> ioProperty $ @@ -701,7 +701,7 @@ ( mrgIf (iint - jint .> fromIntegral (i - j)) (throwError Overflow) - (mrgSingle $ toSym $ i - j :: ExceptT ArithException UnionM (SymWordN 8)) + (mrgSingle $ toSym $ i - j :: ExceptT ArithException Union (SymWordN 8)) ), testProperty "safeNeg on concrete" $ \(i :: Word8) -> ioProperty $ @@ -713,13 +713,13 @@ ( mrgIf (-iint .> fromIntegral (-i)) (throwError Overflow) - (mrgSingle $ toSym $ -i :: ExceptT ArithException UnionM (SymWordN 8)) + (mrgSingle $ toSym $ -i :: ExceptT ArithException Union (SymWordN 8)) ) ] ], testGroup - "SOrd" - [ testProperty "SOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do + "SymOrd" + [ testProperty "SymOrd on concrete" $ \(i :: Integer, j :: Integer) -> ioProperty $ do let iu :: WordN 4 = fromInteger i let ju :: WordN 4 = fromInteger j let is :: IntN 4 = fromInteger i @@ -732,27 +732,27 @@ (con iu :: SymWordN 4) .> con ju @=? (con (normalizeu i > normalizeu j) :: SymBool) (con iu :: SymWordN 4) `symCompare` con ju - @=? (normalizeu i `symCompare` normalizeu j :: UnionM Ordering) + @=? (normalizeu i `symCompare` normalizeu j :: Union Ordering) (con is :: SymIntN 4) .<= con js @=? (con (normalizes i <= normalizes j) :: SymBool) (con is :: SymIntN 4) .< con js @=? (con (normalizes i < normalizes j) :: SymBool) (con is :: SymIntN 4) .>= con js @=? (con (normalizes i >= normalizes j) :: SymBool) (con is :: SymIntN 4) .> con js @=? (con (normalizes i > normalizes j) :: SymBool) (con is :: SymIntN 4) `symCompare` con js - @=? (normalizes i `symCompare` normalizes j :: UnionM Ordering), - testCase "SOrd on symbolic" $ do + @=? (normalizes i `symCompare` normalizes j :: Union Ordering), + testCase "SymOrd on symbolic" $ do au .<= bu @=? SymBool (pevalLeOrdTerm aut but) au .< bu @=? SymBool (pevalLtOrdTerm aut but) au .>= bu @=? SymBool (pevalGeOrdTerm aut but) au .> bu @=? SymBool (pevalGtOrdTerm aut but) - (au `symCompare` bu :: UnionM Ordering) + (au `symCompare` bu :: Union Ordering) @=? mrgIf (au .< bu) (mrgSingle LT) (mrgIf (au .== bu) (mrgSingle EQ) (mrgSingle GT)) as .<= bs @=? SymBool (pevalLeOrdTerm ast bst) as .< bs @=? SymBool (pevalLtOrdTerm ast bst) as .>= bs @=? SymBool (pevalGeOrdTerm ast bst) as .> bs @=? SymBool (pevalGtOrdTerm ast bst) - (as `symCompare` bs :: UnionM Ordering) + (as `symCompare` bs :: Union Ordering) @=? mrgIf (as .< bs) (mrgSingle LT) (mrgIf (as .== bs) (mrgSingle EQ) (mrgSingle GT)) ], testGroup @@ -888,12 +888,12 @@ testGroup "GeneralFun" [ testCase "evaluate" $ do - evaluateSym + evalSym False (buildModel ("a" := (1 :: Integer), "b" := (2 :: Integer))) (con ("a" --> "a" + "b") :: SymInteger -~> SymInteger) @=? (con ("a" --> "a" + 2) :: SymInteger -~> SymInteger) - evaluateSym + evalSym False (buildModel ("a" := (1 :: Integer), "b" := (2 :: Integer), "c" := (3 :: Integer))) (con ("a" --> con ("b" --> "a" + "b" + "c")) :: SymInteger -~> SymInteger -~> SymInteger) diff --git a/test/Grisette/TestUtil/NoMerge.hs b/test/Grisette/TestUtil/NoMerge.hs --- a/test/Grisette/TestUtil/NoMerge.hs +++ b/test/Grisette/TestUtil/NoMerge.hs @@ -12,8 +12,8 @@ import Grisette ( Mergeable (rootStrategy), MergingStrategy (NoStrategy), - UnionM, - UnionMergeable1 (mrgIfPropagatedStrategy), + SymBranching (mrgIfPropagatedStrategy), + Union, ) data NoMerge = NoMerge @@ -22,8 +22,8 @@ instance Mergeable NoMerge where rootStrategy = NoStrategy -oneNotMerged :: UnionM Int +oneNotMerged :: Union Int oneNotMerged = mrgIfPropagatedStrategy "a" (return 1) (return 1) -noMergeNotMerged :: UnionM NoMerge +noMergeNotMerged :: Union NoMerge noMergeNotMerged = mrgIfPropagatedStrategy "a" (return NoMerge) (return NoMerge) diff --git a/test/Grisette/TestUtil/SymbolicAssertion.hs b/test/Grisette/TestUtil/SymbolicAssertion.hs --- a/test/Grisette/TestUtil/SymbolicAssertion.hs +++ b/test/Grisette/TestUtil/SymbolicAssertion.hs @@ -2,18 +2,18 @@ import GHC.Stack (HasCallStack) import Grisette - ( EvaluateSym (evaluateSym), + ( EvalSym (evalSym), LogicalOp (symNot), Model, - SEq ((./=), (.==)), SolvingFailure (Unsat), + SymEq ((./=), (.==)), precise, solve, z3, ) import Test.HUnit (Assertion) -(@?=~) :: (HasCallStack, SEq a, Show a, EvaluateSym a) => a -> a -> Assertion +(@?=~) :: (HasCallStack, SymEq a, Show a, EvalSym a) => a -> a -> Assertion actual @?=~ expected = do cex <- solve (precise z3) (symNot $ actual .== expected) case cex of @@ -25,14 +25,16 @@ [ "Symbolic assertion failed:", " Counterexample model: " ++ show model, " Expected value under the model: " - ++ show (evaluateSym True model expected), + ++ show (evalSym True model expected), " Actual value under the model: " - ++ show (evaluateSym True model actual), + ++ show (evalSym True model actual), " Expected value: " ++ show expected, " Actual value: " ++ show actual ] -(.@?=) :: (HasCallStack, Show a, SEq a, EvaluateSym a) => a -> a -> IO () +infix 1 .@?= + +(.@?=) :: (HasCallStack, Show a, SymEq a, EvalSym a) => a -> a -> IO () (.@?=) actual expected = symShouldEq actual @@ -41,13 +43,13 @@ "Can be not equal, model: " <> show m <> ". Actual value: " - <> show (evaluateSym False m actual) + <> show (evalSym False m actual) <> ". Expected value: " - <> show (evaluateSym False m expected) + <> show (evalSym False m expected) ) symShouldEq :: - (HasCallStack, Show a, SEq a, EvaluateSym a) => + (HasCallStack, Show a, SymEq a, EvalSym a) => a -> a -> (Model -> String) -> diff --git a/test/Grisette/Unified/EvalModeTest.hs b/test/Grisette/Unified/EvalModeTest.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Unified/EvalModeTest.hs @@ -0,0 +1,312 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-} + +{-# HLINT ignore "Unused LANGUAGE pragma" #-} +{-# HLINT ignore "Use fewer imports" #-} + +module Grisette.Unified.EvalModeTest (evalModeTest) where + +import Control.Exception (ArithException (DivideByZero)) +import Control.Monad.Error.Class (MonadError) +import Control.Monad.Except (ExceptT (ExceptT)) +import Control.Monad.Identity (Identity (Identity)) +import GHC.Generics (Generic) +import Grisette + ( BV (bv), + BitwidthMismatch, + Default (Default), + IntN, + Mergeable, + SymBool, + SymIntN, + SymInteger, + Union, + mrgReturn, + ) +import qualified Grisette +import Grisette.Internal.Core.Data.Class.LogicalOp (LogicalOp ((.&&))) +import Grisette.Internal.SymPrim.SomeBV (SomeIntN, SomeSymIntN, ssymBV) +import Grisette.Unified + ( EvalMode, + EvalModeTag (Con), + GetBool, + GetData, + GetIntN, + GetInteger, + GetSomeIntN, + MonadWithMode, + extractData, + mrgIte, + safeDiv, + symIte, + (.<), + (.==), + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +#if MIN_VERSION_base(4,16,0) +import GHC.TypeLits (KnownNat, type (<=)) +#else +import Grisette.Unified + ( SafeUnifiedBV, + SafeUnifiedSomeBV, + UnifiedBV, + UnifiedData, + ) +#endif + +fbool :: + forall mode. (EvalMode mode) => GetBool mode -> GetBool mode -> GetBool mode +fbool l r = + mrgIte + (l .== r :: GetBool mode) + (l .< r) + (symIte (l .&& r) l r) + +finteger :: + forall mode. + (EvalMode mode) => + GetInteger mode -> + GetInteger mode -> + GetInteger mode +finteger l r = + mrgIte + (l .== r :: GetBool mode) + (l + r) + (symIte (l .< r :: GetBool mode) l r) + +#if MIN_VERSION_base(4,16,0) +type BVConstraint mode m n = + (MonadWithMode mode m, MonadError ArithException m, KnownNat n, 1 <= n) +#else +type BVConstraint mode m n = + (MonadWithMode mode m, MonadError ArithException m, SafeUnifiedBV mode n m) +#endif + +fbv :: + forall mode n m. + (BVConstraint mode m n) => + GetIntN mode n -> + GetIntN mode n -> + m (GetIntN mode n) +fbv l r = do + v <- safeDiv @mode @ArithException l r + mrgReturn $ + mrgIte @mode + (l .== r) + (v + r) + (symIte @mode (l .< r) l r) + +#if MIN_VERSION_base(4,16,0) +type BVConstraint' mode m n = + (MonadWithMode mode m, KnownNat n, 1 <= n) +#else +type BVConstraint' mode m n = + ( MonadWithMode mode m, + SafeUnifiedBV mode n (ExceptT ArithException m) + ) +#endif + +fbv' :: + forall mode n m. + (BVConstraint' mode m n) => + GetIntN mode n -> + GetIntN mode n -> + ExceptT ArithException m (GetIntN mode n) +fbv' l r = do + v <- safeDiv @mode l r + mrgReturn $ + mrgIte @mode + (l .== r) + (v + r) + (symIte @mode (l .< r) l r) + +#if MIN_VERSION_base(4,16,0) +type SomeBVConstraint mode m = + (MonadWithMode mode m, MonadError (Either BitwidthMismatch ArithException) m) +#else +type SomeBVConstraint mode m = + ( MonadWithMode mode m, + MonadError (Either BitwidthMismatch ArithException) m, + SafeUnifiedSomeBV mode m + ) +#endif + +fsomebv :: + forall mode m. + (SomeBVConstraint mode m) => + GetSomeIntN mode -> + GetSomeIntN mode -> + m (GetSomeIntN mode) +fsomebv l r = do + v <- safeDiv @mode l r + mrgReturn $ + symIte @mode + (l .== r) + (v + r) + (symIte @mode (l .< r) l r) + +#if MIN_VERSION_base(4,16,0) +type SomeBVConstraint' mode m = + (MonadWithMode mode m) +#else +type SomeBVConstraint' mode m = + ( MonadWithMode mode m, + SafeUnifiedSomeBV mode (ExceptT (Either BitwidthMismatch ArithException) m) + ) +#endif + +fsomebv' :: + forall mode m. + (SomeBVConstraint' mode m) => + GetSomeIntN mode -> + GetSomeIntN mode -> + ExceptT (Either BitwidthMismatch ArithException) m (GetSomeIntN mode) +fsomebv' l r = do + v <- safeDiv @mode l r + mrgReturn $ + symIte @mode + (l .== r) + (v + r) + (symIte @mode (l .< r) l r) + +data A mode = A (GetIntN mode 8) | AT (GetData mode (A mode)) + deriving (Generic) + +#if MIN_VERSION_base(4,16,0) +type DataConstraint mode = (EvalMode mode) +#else +type DataConstraint mode = + (EvalMode mode, UnifiedData mode (A mode), UnifiedBV mode 8) +#endif + +deriving via + (Default (A mode)) + instance + (DataConstraint mode) => + (Mergeable (A mode)) + +#if MIN_VERSION_base(4,16,0) +type FDataConstraint mode m = + (MonadWithMode mode m, MonadError ArithException m) +#else +type FDataConstraint mode m = + ( MonadWithMode mode m, + MonadError ArithException m, + UnifiedData mode (A mode), + SafeUnifiedBV mode 8 m + ) +#endif + +fdata :: + forall mode m. + (FDataConstraint mode m) => + GetData mode (A mode) -> + m (GetIntN mode 8) +fdata d = do + a :: A mode <- extractData @mode d + case a of + A v -> safeDiv @mode v (v - 1) + AT v -> fdata v + +evalModeTest :: Test +evalModeTest = + testGroup + "EvalMode" + [ testGroup + "GetBool" + [ testCase "Con" $ fbool True False @?= False, + testCase "Sym" $ do + let l = "l" :: SymBool + let r = "r" :: SymBool + fbool l r + @?= Grisette.mrgIte + (l Grisette..== r) + (l Grisette..< r) + (Grisette.symIte (l Grisette..&& r) l r) + ], + testGroup + "GetInteger" + [ testCase "Con" $ finteger (1 :: Integer) 2 @?= 1, + testCase "Sym" $ do + let l = "l" :: SymInteger + let r = "r" :: SymInteger + finteger l r + @?= Grisette.mrgIte + (l Grisette..== r) + (l + r) + (Grisette.symIte (l Grisette..< r) l r) + ], + testGroup + "GetIntN" + [ testCase "Con" $ do + fbv (1 :: IntN 8) 2 @?= Right 1 + fbv' (1 :: IntN 8) 2 @?= ExceptT (Identity (Right 1)), + testCase "Sym" $ do + let l = "l" :: SymIntN 8 + let r = "r" :: SymIntN 8 + let expected = do + v <- Grisette.safeDiv l r + mrgReturn $ + Grisette.symIte + (l Grisette..== r) + (v + r) + (Grisette.symIte (l Grisette..< r) l r) :: + ExceptT + ArithException + Union + (SymIntN 8) + fbv l r @?= expected + fbv' l r @?= expected + ], + testGroup + "GetSomeIntN" + [ testCase "Con" $ do + fsomebv (bv 8 1 :: SomeIntN) (bv 8 2) @?= Right (bv 8 1) + fsomebv' (bv 8 1 :: SomeIntN) (bv 8 2) + @?= ExceptT (Identity (Right (bv 8 1))), + testCase "Sym" $ do + let l = ssymBV 8 "l" :: SomeSymIntN + let r = ssymBV 8 "r" :: SomeSymIntN + let expected = do + v <- Grisette.safeDiv l r + mrgReturn $ + Grisette.symIte + (l Grisette..== r) + (v + r) + (Grisette.symIte (l Grisette..< r) l r) :: + ExceptT + (Either BitwidthMismatch ArithException) + Union + SomeSymIntN + fsomebv l r @?= expected + fsomebv' l r @?= expected + ], + testGroup + "GetData" + [ testCase "Con" $ do + fdata @'Con (A 2) @?= Right 2 + fdata @'Con (A 1) @?= Left DivideByZero, + testCase "Sym" $ do + let a = "a" :: SymIntN 8 + fdata (mrgReturn $ A a) + @?= ( Grisette.safeDiv a (a - 1) :: + ExceptT ArithException Union (SymIntN 8) + ) + ] + ] diff --git a/test/Grisette/Unified/UnifiedClassesTest.hs b/test/Grisette/Unified/UnifiedClassesTest.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Unified/UnifiedClassesTest.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Unified.UnifiedClassesTest (unifiedClassesTest) where + +import Control.Monad.Except (ExceptT, MonadError (throwError)) +import qualified Data.Text as T +import GHC.TypeNats (KnownNat, type (<=)) +import Grisette + ( Default (Default), + SymBool, + SymInteger, + SymWordN, + Union, + WordN, + mrgReturn, + ) +import qualified Grisette +import Grisette.TH (deriveAll) +import Grisette.Unified + ( BaseMonad, + EvalMode, + GetBool, + GetData, + GetInteger, + GetWordN, + MonadWithMode, + mrgIf, + (.==), + ) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +type M mode = ExceptT T.Text (BaseMonad mode) + +testBranching :: + forall mode m. + (MonadWithMode mode m, MonadError T.Text m) => + GetInteger mode -> + m (GetInteger mode) +testBranching x = + mrgIf (x .== 1 :: GetBool mode) (return x) (throwError "err") + +testBranchingBase :: + forall mode. (EvalMode mode) => GetInteger mode -> M mode (GetInteger mode) +testBranchingBase x = + mrgIf (x .== 1 :: GetBool mode) (return x) (throwError "err") + +data X mode n + = X + (GetBool mode) + [GetWordN mode n] + (GetData mode (X mode n)) + [GetData mode (X mode n)] + | XNil + +deriveAll ''X + +testSEq :: + forall mode n. + (EvalMode mode, 1 <= n, KnownNat n) => + X mode n -> + X mode n -> + GetBool mode +testSEq = (.==) + +unifiedClassesTest :: Test +unifiedClassesTest = + testGroup + "UnifiedClasses" + [ testGroup + "UnifiedBranching" + [ testCase "branchingBase 'Con" $ + testBranchingBase (1 :: Integer) @?= return 1, + testCase "branchingBase 'Sym" $ do + let a = "a" :: SymInteger + let expected = + Grisette.mrgIf + (a Grisette..== 1) + (return a) + (throwError "err") + testBranchingBase a @?= expected, + testCase "branching 'Con" $ + testBranching 1 @?= (return 1 :: Either T.Text Integer), + testCase "branching 'Sym" $ + testBranching 1 @?= (return 1 :: ExceptT T.Text Union SymInteger) + ], + testGroup + "UnifiedSEq" + [ testCase "testSEq 'Con" $ do + let x1 = X True [1 :: WordN 8] XNil [XNil] + let x2 = X False [1 :: WordN 8] XNil [XNil] + testSEq x1 x1 @?= True + testSEq x1 x2 @?= False, + testCase "testSEq 'Sym" $ do + let x1 = X "a" [1 :: SymWordN 8] (mrgReturn XNil) [mrgReturn XNil] + let x2 = X "b" [1 :: SymWordN 8] (mrgReturn XNil) [mrgReturn XNil] + testSEq x1 x2 @?= ("a" :: SymBool) .== "b" + ] + ] diff --git a/test/Grisette/Unified/UnifiedConstructorTest.hs b/test/Grisette/Unified/UnifiedConstructorTest.hs new file mode 100644 --- /dev/null +++ b/test/Grisette/Unified/UnifiedConstructorTest.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +module Grisette.Unified.UnifiedConstructorTest (unifiedConstructorTest) where + +import Generics.Deriving (Default (Default)) +import Grisette (Solvable (con), SymInteger, ToSym (toSym), mrgReturn) +import Grisette.TH (deriveAll, mkUnifiedConstructor) +import Grisette.Unified.Internal.EvalMode (EvalMode) +import Grisette.Unified.Internal.EvalModeTag (EvalModeTag (Con, Sym)) +import Grisette.Unified.Internal.UnifiedBool (UnifiedBool (GetBool)) +import Grisette.Unified.Internal.UnifiedData (GetData, UnifiedData) +import Test.Framework (Test, testGroup) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit ((@?=)) + +data T mode a + = T (GetBool mode) a (GetData mode (T mode a)) + | T1 + +deriveAll ''T +mkUnifiedConstructor "mk" ''T + +unifiedConstructorTest :: Test +unifiedConstructorTest = + testGroup + "UnifiedConstructor" + [ testCase "mkUnifiedConstructor" $ do + let f :: + forall mode. + (EvalMode mode, UnifiedData mode (T mode SymInteger)) => + GetData mode (T mode SymInteger) + f = + mkT @mode + (toSym True) + (10 :: SymInteger) + (mkT1 @mode @SymInteger) + f @'Con @?= T True 10 T1 + f @'Sym @?= (mrgReturn (T (con True) 10 (mrgReturn T1))) + ] diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -8,28 +8,28 @@ ( termRewritingTests, ) import Grisette.Core.Control.ExceptionTests (exceptionTests) -import Grisette.Core.Control.Monad.UnionMTests (unionMTests) import Grisette.Core.Control.Monad.UnionTests (unionTests) import qualified Grisette.Core.Data.Class.BoolTests -import Grisette.Core.Data.Class.EvaluateSymTests (evaluateSymTests) -import Grisette.Core.Data.Class.ExtractSymbolicsTests (extractSymbolicsTests) -import Grisette.Core.Data.Class.GPrettyTests (gprettyTests) +import Grisette.Core.Data.Class.EvalSymTests (evalSymTests) +import Grisette.Core.Data.Class.ExtractSymTests (extractSymTests) import Grisette.Core.Data.Class.GenSymTests (genSymTests) import Grisette.Core.Data.Class.MergeableTests (mergeableTests) +import Grisette.Core.Data.Class.PPrintTests (pprintTests) import Grisette.Core.Data.Class.PlainUnionTests (plainUnionTests) -import Grisette.Core.Data.Class.SEqTests (seqTests) -import Grisette.Core.Data.Class.SOrdTests (sordTests) import Grisette.Core.Data.Class.SafeDivisionTests (safeDivisionTests) import Grisette.Core.Data.Class.SafeLinearArithTests (safeLinearArithTests) import Grisette.Core.Data.Class.SafeSymRotateTests (safeSymRotateTests) import Grisette.Core.Data.Class.SafeSymShiftTests (safeSymShiftTests) import Grisette.Core.Data.Class.SimpleMergeableTests (simpleMergeableTests) -import Grisette.Core.Data.Class.SubstituteSymTests (substituteSymTests) +import Grisette.Core.Data.Class.SubstSymTests (substSymTests) +import Grisette.Core.Data.Class.SymEqTests (seqTests) +import Grisette.Core.Data.Class.SymOrdTests (sordTests) import Grisette.Core.Data.Class.SymRotateTests (symRotateTests) import Grisette.Core.Data.Class.SymShiftTests (symShiftTests) import Grisette.Core.Data.Class.ToConTests (toConTests) import Grisette.Core.Data.Class.ToSymTests (toSymTests) import Grisette.Core.Data.Class.TryMergeTests (tryMergeTests) +import Grisette.Core.Data.UnionBaseTests (unionBaseTests) import Grisette.Lib.Control.ApplicativeTest (applicativeFunctionTests) import Grisette.Lib.Control.Monad.ExceptTests ( monadExceptFunctionTests, @@ -66,6 +66,9 @@ import Grisette.SymPrim.SomeBVTests (someBVTests) import Grisette.SymPrim.SymPrimTests (symPrimTests) import qualified Grisette.SymPrim.TabularFunTests +import Grisette.Unified.EvalModeTest (evalModeTest) +import Grisette.Unified.UnifiedClassesTest (unifiedClassesTest) +import Grisette.Unified.UnifiedConstructorTest (unifiedConstructorTest) import Test.Framework (Test, defaultMain, testGroup) main :: IO () @@ -74,7 +77,8 @@ [ coreTests, irTests, sbvTests, - libTests + libTests, + unifiedTests ] coreTests :: Test @@ -85,8 +89,7 @@ "Control" [ testGroup "Monad" - [ unionMTests, - unionTests + [ unionTests ], exceptionTests ], @@ -95,10 +98,10 @@ [ testGroup "Class" [ Grisette.Core.Data.Class.BoolTests.boolTests, - evaluateSymTests, - extractSymbolicsTests, + evalSymTests, + extractSymTests, genSymTests, - gprettyTests, + pprintTests, mergeableTests, plainUnionTests, safeDivisionTests, @@ -108,13 +111,14 @@ seqTests, sordTests, simpleMergeableTests, - substituteSymTests, + substSymTests, symRotateTests, symShiftTests, toConTests, toSymTests, tryMergeTests - ] + ], + unionBaseTests ] ] @@ -182,4 +186,13 @@ [ cegisTests, loweringTests, termRewritingTests + ] + +unifiedTests :: Test +unifiedTests = + testGroup + "Grisette.Unified" + [ evalModeTest, + unifiedConstructorTest, + unifiedClassesTest ]